Test-Harness-3.36/0000755000175000017500000000000012640746441012451 5ustar leonleonTest-Harness-3.36/HACKING.pod0000644000175000017500000001431312514133675014222 0ustar leonleon # this is in pod format (try `perldoc HACKING.pod`) =pod =head1 NAME HACKING.pod - contributing to TAP::Harness =head1 ABOUT This is the guide for TAP::Harness internals contributors (developers, testers, documenters.) If you are looking for more information on how to I TAP::Harness, you probably want L instead. =head1 Getting Started See the resources section in I or I for links to the project mailing list, bug tracker, svn repository, etc. For ease of reference, at the time of writing the SVN repository was at: http://svn.hexten.net/tapx To get the latest version of trunk: git clone git://github.com/Perl-Toolchain-Gang/Test-Harness.git For best results, read the rest of this file, check RT for bugs which scratch your itch, join the mailing list, etc. =head1 Formatting =head2 perltidy The project comes with a C<.perltidyrc>, which perltidy will automatically use if the project root is your working directory. This is setup by default to read and write the perl code on a pipe. To configure your editor: =over 4 =item * vim In C<.vimrc>, you can add the following lines: nnoremap pt :%!perltidy -q " only work in 'normal' mode vnoremap pt :!perltidy -q " only work in 'visual' mode In other words, if your C is a backslash, you can type C<\pt> to reformat the file using the C<.perltidyrc>. If you are in visual mode (selecting lines with shift-v), then only the code you have currently have selected will be reformatted. =item * emacs For emacs, you can use this snippet from Sam Tregar (L): (defun perltidy-region () "Run perltidy on the current region." (interactive) (save-excursion (shell-command-on-region (point) (mark) "perltidy -q" nil t) (cperl-mode))) (defun perltidy-all () "Run perltidy on the current region." (interactive) (let ((p (point))) (save-excursion (shell-command-on-region (point-min) (point-max) "perltidy -q" nil t) ) (goto-char p) (cperl-mode))) (global-set-key "\M-t" `perltidy-region) (global-set-key "\M-T" `perltidy-all) =back =head1 Tests and Coverage ... =for eric_not_it TODO link to a good guide on writing tests for TAP::Parser =head1 Writing for Compatibility ... =for eric_not_it TODO explain no bundling, PERL_CORE, etc =head1 Use TAP::Object TAP::Object is the common base class to all TAP::* modules, and should be for any that you write. =head1 Exception Handling Exceptions should be raised with L: require Carp; Carp::croak("Unsupported syntax version: $version"); require Carp; Carp::confess("Unsupported syntax version: $version"); =head1 Deprecation cycle Any I sub that needs to be changed or removed (and would therefore cause a backwards-compat issue) must go through a deprecation cycle to give developers a chance to adjust: 1. Document the deprecation 2. Carp a suitable message 3. Release 4. Change the code 5. Release =head1 Documentation The end-user and API documentation is all in the 'lib/' directory. In .pm files, the pod is "inline" to the code. See L for more about pod. =head2 Pod Commands For compatibility's sake, we do not use the =head3 and =head4 commands. =over =item C<=head1 SECTION> Sections begin with an C<=head1> command and are all-caps. =for eric_not_it I guess... Mixed case messes with various pod hacking tools. NAME VERSION SYNOPSIS CONSTRUCTOR METHODS CLASS METHODS SOME OTHER SORT OF METHODS SEE ALSO =item C<=head2 method> =for eric_not_it The following is how I would do it, but opposite of what we have. The C<=head2> command documents a method. The name of the method should have no adornment (e.g. don't CEmethod> or CEmethod($list, $of, $params)>.) These sections should begin with a short description of what the method does, followed by one or more examples of usage. If needed, elaborate on the subtleties of the parameters and context after (and/or between) the example(s). =head2 this_method This method does some blah blah blah. my @answer = $thing->this_method(@arguments); =head2 that_thing Returns true if the thing is true. if($thing->that_thing) { ... } =item C<=item parameter> Use C<=item> commands for method arguments and parameters (and etc.) In most html pod formatters, these I get added to the table-of-contents at the top of the page. =back =head2 Pod Formatting Codes =over =item LESome::Module> Be careful of the wording of CSome::ModuleE>. Older pod formatters would render this as "the Some::Module manpage", so it is best to either word your links as "C<(see ESome::ModuleE for details.)>" or use the "explicit rendering" form of "CSome::Module|Some::ModuleE>". =back =head2 VERSION The version numbers are updated by L. =head2 DEVELOPER DOCS/NOTES The following "formats" are used with C<=begin>/C<=end> and C<=for> commands for pod which is not part of the public end-user/API documentation. =over =item note Use this if you are uncertain about a change to some pod or think it needs work. =head2 some_method ... =for note This is either falsely documented or a bug -- see ... =item developer =begin developer Long-winded explanation of why some code is the way it is or various other subtleties which might incite head-scratching and WTF'ing. =end developer =item deprecated =for deprecated removed in 0.09, kill by ~0.25 =back =head1 Committing to Subversion If you have commit access, please bear this in mind. Development is done either on trunk or a branch, as appropriate: If it's something that might be controversial, break the build or take a long time (more than a couple of weeks) to complete then it'd probably be appropriate to branch. Otherwise it can go in trunk. If in doubt discuss it on the mailing list before you commit. =cut =for developer ... or whatever. I'm just making stuff up here. If any of this is wrong, please correct it. To the extent that there is an "official policy", it should be written down. --Eric =cut # vim:ts=2:sw=2:et:sta Test-Harness-3.36/MANIFEST.CUMMULATIVE0000644000175000017500000001665212166360606015404 0ustar leonleon.perltidyrc Build.PL Changes Changes-2.64 HACKING.pod MANIFEST MANIFEST.CUMMULATIVE META.yml Makefile.PL NotBuild.PL README TODO bin/prove bin/runtests examples/README examples/analyze_tests.pl examples/bin/forked_tests.pl examples/bin/test_html.pl examples/bin/tprove examples/bin/tprove_color examples/bin/tprove_gtk examples/harness-hook/hook.pl examples/harness-hook/lib/Harness/Hook.pm examples/my_exec examples/my_execrc examples/silent-harness.pl examples/t/10-stuff.t examples/t/ruby.t examples/tapx_harness_execrc examples/test_urls.txt inc/MyBuilder.pm lib/App/Prove.pm lib/App/Prove/State.pm lib/App/Prove/State/Result.pm lib/App/Prove/State/Result/Test.pm lib/TAP/Base.pm lib/TAP/Formatter/Base.pm lib/TAP/Formatter/Color.pm lib/TAP/Formatter/Console.pm lib/TAP/Formatter/Console/ParallelSession.pm lib/TAP/Formatter/Console/Session.pm lib/TAP/Formatter/File.pm lib/TAP/Formatter/File/Session.pm lib/TAP/Formatter/Session.pm lib/TAP/Harness.pm lib/TAP/Harness/Beyond.pod lib/TAP/Harness/Color.pm lib/TAP/Harness/Compatible.pm lib/TAP/Object.pm lib/TAP/Parser.pm lib/TAP/Parser/Aggregator.pm lib/TAP/Parser/Grammar.pm lib/TAP/Parser/Iterator.pm lib/TAP/Parser/Iterator/Array.pm lib/TAP/Parser/Iterator/Process.pm lib/TAP/Parser/Iterator/Stream.pm lib/TAP/Parser/IteratorFactory.pm lib/TAP/Parser/Multiplexer.pm lib/TAP/Parser/Result.pm lib/TAP/Parser/Result/Bailout.pm lib/TAP/Parser/Result/Comment.pm lib/TAP/Parser/Result/Plan.pm lib/TAP/Parser/Result/Pragma.pm lib/TAP/Parser/Result/Test.pm lib/TAP/Parser/Result/Unknown.pm lib/TAP/Parser/Result/Version.pm lib/TAP/Parser/Result/YAML.pm lib/TAP/Parser/ResultFactory.pm lib/TAP/Parser/Scheduler.pm lib/TAP/Parser/Scheduler/Job.pm lib/TAP/Parser/Scheduler/Spinner.pm lib/TAP/Parser/Source.pm lib/TAP/Parser/Source/Perl.pm lib/TAP/Parser/SourceHandler.pm lib/TAP/Parser/SourceHandler/Executable.pm lib/TAP/Parser/SourceHandler/File.pm lib/TAP/Parser/SourceHandler/Handle.pm lib/TAP/Parser/SourceHandler/Perl.pm lib/TAP/Parser/SourceHandler/RawTAP.pm lib/TAP/Parser/Utils.pm lib/TAP/Parser/YAML.pm lib/TAP/Parser/YAMLish/Reader.pm lib/TAP/Parser/YAMLish/Writer.pm lib/TAPx/Base.pm lib/TAPx/Harness.pm lib/TAPx/Harness/Color.pm lib/TAPx/Harness/Compatible.pm lib/TAPx/Harness/Compatible/Iterator.pm lib/TAPx/Harness/Compatible/Point.pm lib/TAPx/Harness/Compatible/Results.pm lib/TAPx/Harness/Compatible/Straps.pm lib/TAPx/Harness/Compatible/TAP.pod lib/TAPx/Harness/Compatible/Util.pm lib/TAPx/Parser.pm lib/TAPx/Parser/Aggregator.pm lib/TAPx/Parser/Grammar.pm lib/TAPx/Parser/Iterator.pm lib/TAPx/Parser/Result.pm lib/TAPx/Parser/Result/Bailout.pm lib/TAPx/Parser/Result/Comment.pm lib/TAPx/Parser/Result/Plan.pm lib/TAPx/Parser/Result/Test.pm lib/TAPx/Parser/Result/Unknown.pm lib/TAPx/Parser/Source.pm lib/TAPx/Parser/Source/Perl.pm lib/TAPx/Parser/YAML.pm lib/Test/Harness.pm patches/ExtUtils-MakeMaker-6.31.patch perlcriticrc perltidyrc t/000-load.t t/010-base.t t/010-regression.t t/020-parse.t t/020-regression.t t/030-bailout.t t/030-grammar.t t/040-errors.t t/040-parse.t t/050-bailout.t t/050-streams.t t/060-aggregator.t t/060-errors.t t/070-callbacks.t t/070-streams.t t/080-aggregator.t t/080-premature-bailout.t t/090-callbacks.t t/090-iterators.t t/100-harness.t t/100-premature-bailout.t t/110-iterators.t t/110-source.t t/120-harness.t t/130-source.t t/140-results.t t/140-varsource.t t/150-results.t t/150-yamlish.t t/160-yaml.t t/160-yamlish-writer.t t/170-yamlish-output.t t/180-unicode.t t/190-nofork.t t/200-prove.t t/aggregator.t t/bailout.t t/base.t t/callbacks.t t/compat/000-compile.t t/compat/00compile.t t/compat/010-failure.t t/compat/020-inc_taint.t t/compat/030-nonumbers.t t/compat/040-test-harness-compat.t t/compat/060-version.t t/compat/base.t t/compat/callback.t t/compat/env.t t/compat/failure.t t/compat/from_line.t t/compat/harness.t t/compat/inc-propagation.t t/compat/inc_taint.t t/compat/nonumbers.t t/compat/ok.t t/compat/point-parse.t t/compat/point.t t/compat/prove-globbing.t t/compat/prove-switches.t t/compat/regression.t t/compat/strap-analyze.t t/compat/strap.t t/compat/subclass.t t/compat/switches.t t/compat/test-harness-compat.t t/compat/test-harness.t t/compat/version.t t/console.t t/data/catme.1 t/data/execrc t/data/proverc t/data/sample.yml t/errors.t t/file.t t/glob-to-regexp.t t/grammar.t t/harness-bailout.t t/harness-subclass.t t/harness.t t/iterator_factory.t t/iterators.t t/lib/App/Prove/Plugin/Dummy.pm t/lib/App/Prove/Plugin/Dummy2.pm t/lib/Dev/Null.pm t/lib/EmptyParser.pm t/lib/IO/Capture.pm t/lib/IO/c55Capture.pm t/lib/MyCustom.pm t/lib/MyFileSourceHandler.pm t/lib/MyGrammar.pm t/lib/MyIterator.pm t/lib/MyIteratorFactory.pm t/lib/MyPerlSource.pm t/lib/MyPerlSourceHandler.pm t/lib/MyResult.pm t/lib/MyResultFactory.pm t/lib/MySource.pm t/lib/MySourceHandler.pm t/lib/NOP.pm t/lib/NoFork.pm t/lib/TAP/Harness/TestSubclass.pm t/lib/TAP/Parser/SubclassTest.pm t/lib/Test/Builder.pm t/lib/Test/Builder/Module.pm t/lib/Test/More.pm t/lib/Test/Simple.pm t/lib/if.pm t/multiplexer.t t/nested.t t/nofork-mux.t t/nofork.t t/object.t t/parse.t t/parser-config.t t/parser-subclass.t t/perl5lib.t t/pod-coverage.t t/pod.t t/premature-bailout.t t/process.t t/prove.t t/proveenv.t t/proverc.t t/proverc/emptyexec t/proverun.t t/proveversion.t t/regression.t t/results.t t/sample-tests/bailout t/sample-tests/bignum t/sample-tests/bignum_many t/sample-tests/combined t/sample-tests/combined_compat t/sample-tests/delayed t/sample-tests/descriptive t/sample-tests/descriptive_trailing t/sample-tests/die t/sample-tests/die_head_end t/sample-tests/die_last_minute t/sample-tests/die_unfinished t/sample-tests/duplicates t/sample-tests/echo t/sample-tests/empty t/sample-tests/escape_eol t/sample-tests/escape_hash t/sample-tests/head_end t/sample-tests/head_fail t/sample-tests/inc_taint t/sample-tests/junk_before_plan t/sample-tests/lone_not_bug t/sample-tests/no_nums t/sample-tests/no_output t/sample-tests/out_err_mix t/sample-tests/out_of_order t/sample-tests/schwern t/sample-tests/schwern-todo-quiet t/sample-tests/segfault t/sample-tests/sequence_misparse t/sample-tests/shbang_misparse t/sample-tests/simple t/sample-tests/simple_fail t/sample-tests/simple_yaml t/sample-tests/simple_yaml_missing_version13 t/sample-tests/skip t/sample-tests/skip_nomsg t/sample-tests/skipall t/sample-tests/skipall_nomsg t/sample-tests/skipall_v13 t/sample-tests/space_after_plan t/sample-tests/stdout_stderr t/sample-tests/strict t/sample-tests/switches t/sample-tests/taint t/sample-tests/taint_warn t/sample-tests/todo t/sample-tests/todo_inline t/sample-tests/todo_misparse t/sample-tests/too_many t/sample-tests/version_good t/sample-tests/version_late t/sample-tests/version_old t/sample-tests/vms_nit t/sample-tests/with_comments t/sample-tests/yaml_late_plan t/sample-tests/zero_valid t/scheduler.t t/source.t t/source_handler.t t/source_tests/harness t/source_tests/harness_badtap t/source_tests/harness_complain t/source_tests/harness_directives t/source_tests/harness_failure t/source_tests/psql t/source_tests/psql.bat t/source_tests/source t/source_tests/source.1 t/source_tests/source.bat t/source_tests/source.pl t/source_tests/source.sh t/source_tests/source.t t/source_tests/source.tap t/source_tests/source_args.sh t/source_tests/varsource t/spool.t t/state.t t/state_results.t t/streams.t t/subclass_tests/non_perl_source t/subclass_tests/perl_source t/taint.t t/testargs.t t/unicode.t t/utils.t t/yamlish-output.t t/yamlish-writer.t t/yamlish.t xt/author/pod-coverage.t xt/author/pod.t xt/author/stdin.t xt/perls/harness_perl.t xt/perls/sample-tests/perl_version Test-Harness-3.36/t/0000755000175000017500000000000012640746441012714 5ustar leonleonTest-Harness-3.36/t/parser-config.t0000644000175000017500000000133312426525633015640 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; our (%INIT, %CUSTOM); use Test::More tests => 5; use File::Spec::Functions qw( catfile updir ); use TAP::Parser; use_ok('MyGrammar'); use_ok('MyResultFactory'); my @t_path = (); my $source = catfile( @t_path, 't', 'source_tests', 'source' ); my %customize = ( grammar_class => 'MyGrammar', result_factory_class => 'MyResultFactory', ); my $p = TAP::Parser->new( { source => $source, %customize, } ); ok( $p, 'new customized parser' ); for my $key ( keys %customize ) { is( $p->$key(), $customize{$key}, "customized $key" ); } # TODO: make sure these things are propogated down through the parser... Test-Harness-3.36/t/callbacks.t0000644000175000017500000000510412426525242015014 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 10; use TAP::Parser; use TAP::Parser::Iterator::Array; my $tap = <<'END_TAP'; 1..5 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure ok 5 # skip we have no description END_TAP my @tests; my $plan_output; my $todo = 0; my $skip = 0; my %callbacks = ( test => sub { my $test = shift; push @tests => $test; $todo++ if $test->has_todo; $skip++ if $test->has_skip; }, plan => sub { my $plan = shift; $plan_output = $plan->as_string; } ); my $iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); my $parser = TAP::Parser->new( { iterator => $iterator, callbacks => \%callbacks, } ); can_ok $parser, 'run'; $parser->run; is $plan_output, '1..5', 'Plan callbacks should succeed'; is scalar @tests, $parser->tests_run, '... as should the test callbacks'; @tests = (); $plan_output = ''; $todo = 0; $skip = 0; my $else = 0; my $all = 0; my $end = 0; %callbacks = ( test => sub { my $test = shift; push @tests => $test; $todo++ if $test->has_todo; $skip++ if $test->has_skip; }, plan => sub { my $plan = shift; $plan_output = $plan->as_string; }, EOF => sub { my $p = shift; $end = 1 if $all == 8 and $p->isa('TAP::Parser'); }, ELSE => sub { $else++; }, ALL => sub { $all++; }, ); $iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); $parser = TAP::Parser->new( { iterator => $iterator, callbacks => \%callbacks, } ); can_ok $parser, 'run'; $parser->run; is $plan_output, '1..5', 'Plan callbacks should succeed'; is scalar @tests, $parser->tests_run, '... as should the test callbacks'; is $else, 2, '... and the correct number of "ELSE" lines should be seen'; is $all, 8, '... and the correct total number of lines should be seen'; is $end, 1, 'EOF callback correctly called'; # Check callback name policing %callbacks = ( sometest => sub { }, plan => sub { }, random => sub { }, ALL => sub { }, ELSES => sub { }, ); $iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); eval { $parser = TAP::Parser->new( { iterator => $iterator, callbacks => \%callbacks, } ); }; like $@, qr/Callback/, 'Bad callback keys faulted'; Test-Harness-3.36/t/proverc/0000755000175000017500000000000012640746441014374 5ustar leonleonTest-Harness-3.36/t/proverc/emptyexec0000644000175000017500000000001312166360606016312 0ustar leonleon--exec '' Test-Harness-3.36/t/source_tests/0000755000175000017500000000000012640746441015436 5ustar leonleonTest-Harness-3.36/t/source_tests/harness0000644000175000017500000000011312166360606017015 0ustar leonleon#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - this is a test END_TESTS Test-Harness-3.36/t/source_tests/source.pl0000644000175000017500000000010612166360606017266 0ustar leonleon#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - source.pl END_TESTS Test-Harness-3.36/t/source_tests/source.bat0000644000175000017500000000014712166360606017426 0ustar leonleon@ECHO OFF REM this comment will fail if you try to run it through sh! ECHO 1..1 ECHO ok 1 - source.bat Test-Harness-3.36/t/source_tests/source_args.sh0000755000175000017500000000006612166360606020311 0ustar leonleon#!/bin/sh echo "1..1" echo "ok 1 - source_args.sh $1" Test-Harness-3.36/t/source_tests/harness_badtap0000644000175000017500000000016012166360606020332 0ustar leonleon#!/usr/bin/perl print <<'END_TESTS'; 1..2 ok 1 - this is a test not ok 2 - this is another test 1..2 END_TESTS Test-Harness-3.36/t/source_tests/source.tap0000644000175000017500000000002712166360606017441 0ustar leonleon1..1 ok 1 - source.tap Test-Harness-3.36/t/source_tests/source.sh0000755000175000017500000000005612166360606017274 0ustar leonleon#!/bin/sh echo "1..1" echo "ok 1 - source.sh" Test-Harness-3.36/t/source_tests/source.10000644000175000017500000000002512166360606017013 0ustar leonleon1..1 ok 1 - source.1 Test-Harness-3.36/t/source_tests/harness_failure0000644000175000017500000000035312166360606020532 0ustar leonleon#!/usr/bin/perl print <<'END_TESTS'; 1..2 ok 1 - this is a test not ok 2 - this is another test # Failed test 'this is another test' # in harness_failure.t at line 5. # got: 'waffle' # expected: 'yarblokos' END_TESTS Test-Harness-3.36/t/source_tests/harness_complain0000644000175000017500000000016512166360606020706 0ustar leonleon#!/usr/bin/perl print "1..1\n"; die "I should have no args -- @ARGV" if (@ARGV); print "ok 1 - this is a test\n"; Test-Harness-3.36/t/source_tests/source0000644000175000017500000000022512166360606016656 0ustar leonleon#!/usr/bin/perl -wT BEGIN { unshift @INC, 't/lib'; unshift @INC, '../../lib' if $ENV{PERL_CORE}; } use Test::More tests => 1; ok 1, 'source'; Test-Harness-3.36/t/source_tests/source.t0000644000175000017500000000010512426525242017113 0ustar leonleon#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - source.t END_TESTS Test-Harness-3.36/t/source_tests/psql.bat0000755000175000017500000000067312166360606017114 0ustar leonleon@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 Test-Harness-3.36/t/source_tests/harness_directives0000644000175000017500000000026312166360606021244 0ustar leonleon#!/usr/bin/perl print <<'END_TESTS'; 1..3 ok 1 - this is a test not ok 2 - we have a something # TODO some output ok 3 houston, we don't have liftoff # SKIP no funding END_TESTS Test-Harness-3.36/t/state_results.t0000644000175000017500000001171112426525243016000 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More tests => 25; use App::Prove::State; my $test_suite_data = test_suite_data(); # # Test test suite results # can_ok 'App::Prove::State::Result', 'new'; isa_ok my $result = App::Prove::State::Result->new($test_suite_data), 'App::Prove::State::Result', '... and the object it returns'; ok $result, 'state_version'; ok defined $result->state_version, '... and it should be defined'; can_ok $result, 'generation'; is $result->generation, $test_suite_data->{generation}, '... and it should return the correct generation'; can_ok $result, 'num_tests'; is $result->num_tests, scalar keys %{ $test_suite_data->{tests} }, '... and it should return the number of tests run'; can_ok $result, 'raw'; is_deeply $result->raw, $test_suite_data, '... and it should return the raw, unblessed data'; # # Check individual tests. # can_ok $result, 'tests'; can_ok $result, 'test'; eval { $result->test }; my $error = $@; like $error, qr/^\Qtest() requires a test name/, '... and it should croak() if a test name is not supplied'; my $name = 't/compat/failure.t'; ok my $test = $result->test('t/compat/failure.t'), 'result() should succeed if the test name is found'; isa_ok $test, 'App::Prove::State::Result::Test', '... and the object it returns'; can_ok $test, 'name'; is $test->name, $name, '... and it should return the test name'; can_ok $test, 'last_pass_time'; like $test->last_pass_time, qr/^\d+\.\d+$/, '... and it should return a numeric value'; can_ok $test, 'last_fail_time'; ok !defined $test->last_fail_time, '... and it should return undef if the test has never failed'; can_ok $result, 'remove'; ok $result->remove($name), '... and calling it should succeed'; ok $test = $result->test($name), '... and fetching the removed test should suceed'; ok !defined $test->last_pass_time, '... and it should have clean values'; sub test_suite_data { return { 'version' => App::Prove::State::Result->state_version, 'generation' => '51', 'tests' => { 't/compat/failure.t' => { 'last_result' => '0', 'last_run_time' => '1196371471.57738', 'last_pass_time' => '1196371471.57738', 'total_passes' => '48', 'seq' => '1549', 'gen' => '51', 'elapsed' => 0.1230, 'last_todo' => '1', 'mtime' => 1196285623, }, 't/yamlish-writer.t' => { 'last_result' => '0', 'last_run_time' => '1196371480.5761', 'last_pass_time' => '1196371480.5761', 'last_fail_time' => '1196368609', 'total_passes' => '41', 'seq' => '1578', 'gen' => '49', 'elapsed' => 12.2983, 'last_todo' => '0', 'mtime' => 1196285400, }, 't/compat/env.t' => { 'last_result' => '0', 'last_run_time' => '1196371471.42967', 'last_pass_time' => '1196371471.42967', 'last_fail_time' => '1196368608', 'total_passes' => '48', 'seq' => '1548', 'gen' => '52', 'elapsed' => 3.1290, 'last_todo' => '0', 'mtime' => 1196285739, }, 't/compat/version.t' => { 'last_result' => '2', 'last_run_time' => '1196371472.96476', 'last_pass_time' => '1196371472.96476', 'last_fail_time' => '1196368609', 'total_passes' => '47', 'seq' => '1555', 'gen' => '51', 'elapsed' => 0.2363, 'last_todo' => '4', 'mtime' => 1196285239, }, 't/compat/inc_taint.t' => { 'last_result' => '3', 'last_run_time' => '1196371471.89682', 'last_pass_time' => '1196371471.89682', 'total_passes' => '47', 'seq' => '1551', 'gen' => '51', 'elapsed' => 1.6938, 'last_todo' => '0', 'mtime' => 1196185639, }, 't/source.t' => { 'last_result' => '0', 'last_run_time' => '1196371479.72508', 'last_pass_time' => '1196371479.72508', 'total_passes' => '41', 'seq' => '1570', 'gen' => '51', 'elapsed' => 0.0143, 'last_todo' => '0', 'mtime' => 1186285639, }, } }; } Test-Harness-3.36/t/harness-bailout.t0000644000175000017500000000230412426525244016176 0ustar leonleon#!perl use strict; use warnings; use File::Spec; BEGIN { *CORE::GLOBAL::exit = sub { die '!exit called!' }; } use TAP::Harness; use Test::More; my @jobs = ( { name => 'sequential', args => { verbosity => -9 }, }, { name => 'parallel', args => { verbosity => -9, jobs => 2 }, }, ); plan tests => @jobs * 2; for my $test (@jobs) { my $name = $test->{name}; my $args = $test->{args}; my $harness = TAP::Harness->new($args); eval { local ( *OLDERR, *OLDOUT ); open OLDERR, '>&STDERR' or die $!; open OLDOUT, '>&STDOUT' or die $!; my $devnull = File::Spec->devnull; open STDERR, ">$devnull" or die $!; open STDOUT, ">$devnull" or die $!; $harness->runtests( File::Spec->catfile( 't', 'sample-tests', 'bailout' ) ); open STDERR, '>&OLDERR' or die $!; open STDOUT, '>&OLDOUT' or die $!; }; my $err = $@; unlike $err, qr{!exit called!}, "$name: didn't exit"; like $err, qr{FAILED--Further testing stopped: GERONIMMMOOOOOO!!!}, "$name: bailout message"; } # vim:ts=2:sw=2:et:ft=perl Test-Harness-3.36/t/yamlish-output.t0000644000175000017500000000470012426525245016105 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 9; use TAP::Parser::YAMLish::Writer; my $out = [ "---", "bill-to:", " address:", " city: \"Royal Oak\"", " lines: \"458 Walkman Dr.\\nSuite #292\\n\"", " postal: 48046", " state: MI", " family: Dumars", " given: Chris", "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"", "date: 2001-01-23", "invoice: 34843", "product:", " -", " description: Basketball", " price: 450.00", " quantity: 4", " sku: BL394D", " -", " description: \"Super Hoop\"", " price: 2392.00", " quantity: 1", " sku: BL4438H", "tax: 251.42", "total: 4443.52", "...", ]; my $in = { 'bill-to' => { 'given' => 'Chris', 'address' => { 'city' => 'Royal Oak', 'postal' => '48046', 'lines' => "458 Walkman Dr.\nSuite #292\n", 'state' => 'MI' }, 'family' => 'Dumars' }, 'invoice' => '34843', 'date' => '2001-01-23', 'tax' => '251.42', 'product' => [ { 'sku' => 'BL394D', 'quantity' => '4', 'price' => '450.00', 'description' => 'Basketball' }, { 'sku' => 'BL4438H', 'quantity' => '1', 'price' => '2392.00', 'description' => 'Super Hoop' } ], 'comments' => "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", 'total' => '4443.52' }; my @buf1 = (); my @buf2 = (); my $buf3 = ''; my @destination = ( { name => 'Array reference', destination => \@buf1, normalise => sub { return \@buf1 }, }, { name => 'Closure', destination => sub { push @buf2, shift }, normalise => sub { return \@buf2 }, }, { name => 'Scalar', destination => \$buf3, normalise => sub { my @ar = split( /\n/, $buf3 ); return \@ar; }, }, ); for my $dest (@destination) { my $name = $dest->{name}; ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created"; isa_ok $yaml, 'TAP::Parser::YAMLish::Writer'; $yaml->write( $in, $dest->{destination} ); my $got = $dest->{normalise}->(); is_deeply $got, $out, "$name: Result matches"; } Test-Harness-3.36/t/harness.t0000644000175000017500000007060412426525250014546 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More; use IO::c55Capture; use TAP::Harness; # This is done to prevent the colors environment variables from # interfering. local $ENV{HARNESS_SUMMARY_COLOR_FAIL}; local $ENV{HARNESS_SUMMARY_COLOR_SUCCESS}; delete $ENV{HARNESS_SUMMARY_COLOR_FAIL}; delete $ENV{HARNESS_SUMMARY_COLOR_SUCCESS}; my $HARNESS = 'TAP::Harness'; my $source_tests = 't/source_tests'; my $sample_tests = 't/sample-tests'; plan tests => 132; # note that this test will always pass when run through 'prove' ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set'; #### For color tests #### package Colorizer; sub new { bless {}, shift } sub can_color {1} sub set_color { my ( $self, $output, $color ) = @_; $output->("[[$color]]"); } package main; sub colorize { my $harness = shift; $harness->formatter->_colorizer( Colorizer->new ); } can_ok $HARNESS, 'new'; eval { $HARNESS->new( { no_such_key => 1 } ) }; like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/, '... and calling it with bad keys should fail'; eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) }; is $@, '', '... and calling it with a non-existent lib is fine'; eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) }; is $@, '', '... and calling it with non-existent libs is fine'; ok my $harness = $HARNESS->new, 'Calling new() without arguments should succeed'; for my $test_args ( get_arg_sets() ) { my %args = %$test_args; for my $key ( sort keys %args ) { $args{$key} = $args{$key}{in}; } ok my $harness = $HARNESS->new( {%args} ), 'Calling new() with valid arguments should succeed'; isa_ok $harness, $HARNESS, '... and the object it returns'; while ( my ( $property, $test ) = each %$test_args ) { my $value = $test->{out}; can_ok $harness, $property; is_deeply scalar $harness->$property(), $value, $test->{test_name}; } } { my @output; no warnings 'redefine'; local *TAP::Formatter::Base::_output = sub { my $self = shift; push @output => grep { $_ ne '' } map { local $_ = $_; chomp; trim($_) } @_; }; my $harness = TAP::Harness->new( { verbosity => 1, formatter_class => "TAP::Formatter::Console" } ); my $harness_whisper = TAP::Harness->new( { verbosity => -1, formatter_class => "TAP::Formatter::Console" } ); my $harness_mute = TAP::Harness->new( { verbosity => -2, formatter_class => "TAP::Formatter::Console" } ); my $harness_directives = TAP::Harness->new( { directives => 1, formatter_class => "TAP::Formatter::Console" } ); my $harness_failures = TAP::Harness->new( { failures => 1, formatter_class => "TAP::Formatter::Console" } ); colorize($harness); can_ok $harness, 'runtests'; # normal tests in verbose mode ok my $aggregate = _runtests( $harness, "$source_tests/harness" ), '... runtests returns the aggregate'; isa_ok $aggregate, 'TAP::Parser::Aggregator'; chomp(@output); my @expected = ( "$source_tests/harness ..", '1..1', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', 'ok', '[[green]]', 'All tests successful.', '[[reset]]', ); my $status = pop @output; my $expected_status = qr{^Result: PASS$}; my $summary = pop @output; my $expected_summary = qr{^Files=1, Tests=1, +\d+ wallclock secs}; is_deeply \@output, \@expected, '... and the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # use an alias for test name @output = (); ok $aggregate = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ), '... runtests returns the aggregate'; isa_ok $aggregate, 'TAP::Parser::Aggregator'; chomp(@output); @expected = ( 'My Nice Test ..', '1..1', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', 'ok', '[[green]]', 'All tests successful.', '[[reset]]', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr{^Files=1, Tests=1, +\d+ wallclock secs}; is_deeply \@output, \@expected, '... and the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # run same test twice @output = (); ok $aggregate = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ], [ "$source_tests/harness", 'My Nice Test Again' ] ), '... runtests returns the aggregate'; isa_ok $aggregate, 'TAP::Parser::Aggregator'; chomp(@output); @expected = ( 'My Nice Test ........', '1..1', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', 'ok', 'My Nice Test Again ..', '1..1', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', 'ok', '[[green]]', 'All tests successful.', '[[reset]]', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr{^Files=2, Tests=2, +\d+ wallclock secs}; is_deeply \@output, \@expected, '... and the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # normal tests in quiet mode @output = (); _runtests( $harness_whisper, "$source_tests/harness" ); chomp(@output); @expected = ( "$source_tests/harness ..", 'ok', 'All tests successful.', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr/^Files=1, Tests=1, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # normal tests in really_quiet mode @output = (); _runtests( $harness_mute, "$source_tests/harness" ); chomp(@output); @expected = ( 'All tests successful.', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr/^Files=1, Tests=1, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # normal tests with failures @output = (); _runtests( $harness, "$source_tests/harness_failure" ); $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... and the status line should be correct'; my @summary = @output[ 18 .. $#output ]; @output = @output[ 0 .. 17 ]; @expected = ( "$source_tests/harness_failure ..", '1..2', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', '[[red]]', 'not ok 2 - this is another test', '[[reset]]', q{# Failed test 'this is another test'}, '[[reset]]', '# in harness_failure.t at line 5.', '[[reset]]', q{# got: 'waffle'}, '[[reset]]', q{# expected: 'yarblokos'}, '[[reset]]', '[[red]]', 'Failed 1/2 subtests', ); is_deeply \@output, \@expected, '... and failing test output should be correct'; my @expected_summary = ( '[[reset]]', 'Test Summary Report', '-------------------', '[[red]]', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", '[[reset]]', '[[red]]', 'Failed test:', '[[reset]]', '[[red]]', '2', '[[reset]]', ); is_deeply \@summary, \@expected_summary, '... and the failure summary should also be correct'; # quiet tests with failures @output = (); _runtests( $harness_whisper, "$source_tests/harness_failure" ); $status = pop @output; $summary = pop @output; @expected = ( "$source_tests/harness_failure ..", 'Failed 1/2 subtests', 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); like $status, qr{^Result: FAIL$}, '... and the status line should be correct'; is_deeply \@output, \@expected, '... and failing test output should be correct'; # really quiet tests with failures @output = (); _runtests( $harness_mute, "$source_tests/harness_failure" ); $status = pop @output; $summary = pop @output; @expected = ( 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); like $status, qr{^Result: FAIL$}, '... and the status line should be correct'; is_deeply \@output, \@expected, '... and failing test output should be correct'; # only show directives @output = (); _runtests( $harness_directives, "$source_tests/harness_directives" ); chomp(@output); @expected = ( "$source_tests/harness_directives ..", 'not ok 2 - we have a something # TODO some output', "ok 3 houston, we don't have liftoff # SKIP no funding", 'ok', 'All tests successful.', # ~TODO {{{ this should be an option #'Test Summary Report', #'-------------------', #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)", #'Tests skipped:', #'3', # }}} ); $status = pop @output; $summary = pop @output; $expected_summary = qr/^Files=1, Tests=3, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; # normal tests with bad tap # install callback handler my $parser; my $callback_count = 0; my @callback_log = (); for my $evt (qw(parser_args made_parser before_runtests after_runtests)) { $harness->callback( $evt => sub { push @callback_log, $evt; } ); } $harness->callback( made_parser => sub { $parser = shift; $callback_count++; } ); @output = (); _runtests( $harness, "$source_tests/harness_badtap" ); chomp(@output); @output = map { trim($_) } @output; $status = pop @output; @summary = @output[ 12 .. ( $#output - 1 ) ]; @output = @output[ 0 .. 11 ]; @expected = ( "$source_tests/harness_badtap ..", '1..2', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', '[[red]]', 'not ok 2 - this is another test', '[[reset]]', '1..2', '[[reset]]', '[[red]]', 'Failed 1/2 subtests', ); is_deeply \@output, \@expected, '... and failing test output should be correct'; like $status, qr{^Result: FAIL$}, '... and the status line should be correct'; @expected_summary = ( '[[reset]]', 'Test Summary Report', '-------------------', '[[red]]', "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)", '[[reset]]', '[[red]]', 'Failed test:', '[[reset]]', '[[red]]', '2', '[[reset]]', '[[red]]', 'Parse errors: More than one plan found in TAP output', '[[reset]]', ); is_deeply \@summary, \@expected_summary, '... and the badtap summary should also be correct'; cmp_ok( $callback_count, '==', 1, 'callback called once' ); is_deeply( \@callback_log, [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ], 'callback log matches' ); isa_ok $parser, 'TAP::Parser'; # coverage testing for _should_show_failures # only show failures @output = (); _runtests( $harness_failures, "$source_tests/harness_failure" ); chomp(@output); @expected = ( "$source_tests/harness_failure ..", 'not ok 2 - this is another test', 'Failed 1/2 subtests', 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... and the status line should be correct'; $expected_summary = qr/^Files=1, Tests=2, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; # check the status output for no tests @output = (); _runtests( $harness_failures, "$sample_tests/no_output" ); chomp(@output); @expected = ( "$sample_tests/no_output ..", 'No subtests run', 'Test Summary Report', '-------------------', "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)", 'Parse errors: No plan found in TAP output', ); $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... and the status line should be correct'; $expected_summary = qr/^Files=1, Tests=2, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; #XXXX } # make sure we can exec something ... anything! SKIP: { my $cat = '/bin/cat'; # TODO: use TYPE on win32? unless ( -e $cat ) { skip "no '$cat'", 2; } my $capture = IO::c55Capture->new_handle; my $harness = TAP::Harness->new( { verbosity => -2, stdout => $capture, exec => [$cat], } ); eval { _runtests( $harness, 't/data/catme.1' ); }; my @output = tied($$capture)->dump; my $status = pop @output; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; pop @output; # get rid of summary line my $answer = pop @output; is( $answer, "All tests successful.\n", 'cat meows' ); } # make sure that we can exec with a code ref. { my $capture = IO::c55Capture->new_handle; my $harness = TAP::Harness->new( { verbosity => -2, stdout => $capture, exec => sub {undef}, } ); _runtests( $harness, "$source_tests/harness" ); my @output = tied($$capture)->dump; my $status = pop @output; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; pop @output; # get rid of summary line my $answer = pop @output; is( $answer, "All tests successful.\n", 'cat meows' ); } # Exec with a coderef that returns an arrayref SKIP: { my $cat = '/bin/cat'; unless ( -e $cat ) { skip "no '$cat'", 2; } my $capture = IO::c55Capture->new_handle; my $harness = TAP::Harness->new( { verbosity => -2, stdout => $capture, exec => sub { return [ $cat, 't/data/catme.1' ]; }, } ); _runtests( $harness, "$source_tests/harness" ); my @output = tied($$capture)->dump; my $status = pop @output; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; pop @output; # get rid of summary line my $answer = pop @output; is( $answer, "All tests successful.\n", 'cat meows' ); } # Exec with a coderef that returns raw TAP { my $capture = IO::c55Capture->new_handle; my $harness = TAP::Harness->new( { verbosity => -2, stdout => $capture, exec => sub { return "1..1\nok 1 - raw TAP\n"; }, } ); _runtests( $harness, "$source_tests/harness" ); my @output = tied($$capture)->dump; my $status = pop @output; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; pop @output; # get rid of summary line my $answer = pop @output; is( $answer, "All tests successful.\n", 'cat meows' ); } # Exec with a coderef that returns a filehandle { my $capture = IO::c55Capture->new_handle; my $harness = TAP::Harness->new( { verbosity => -2, stdout => $capture, exec => sub { open my $fh, 't/data/catme.1'; return $fh; }, } ); _runtests( $harness, "$source_tests/harness" ); my @output = tied($$capture)->dump; my $status = pop @output; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; pop @output; # get rid of summary line my $answer = pop @output; is( $answer, "All tests successful.\n", 'cat meows' ); } # catches "exec accumulates arguments" issue (r77) { my $capture = IO::c55Capture->new_handle; my $harness = TAP::Harness->new( { verbosity => -2, stdout => $capture, exec => [$^X] } ); _runtests( $harness, "$source_tests/harness_complain" , # will get mad if run with args "$source_tests/harness", ); my @output = tied($$capture)->dump; my $status = pop @output; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; pop @output; # get rid of summary line is( $output[-1], "All tests successful.\n", 'No exec accumulation' ); } # 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]; } sub liblist { return [ map {"-I$_"} @_ ]; } sub get_arg_sets { # keys are keys to new() return { lib => { in => 'lib', out => liblist('lib'), test_name => '... a single lib switch should be correct' }, verbosity => { in => 1, out => 1, test_name => '... and we should be able to set verbosity to 1' }, # verbose => { # in => 1, # out => 1, # test_name => '... and we should be able to set verbose to true' # }, }, { lib => { in => [ 'lib', 't' ], out => liblist( 'lib', 't' ), test_name => '... multiple lib dirs should be correct' }, verbosity => { in => 0, out => 0, test_name => '... and we should be able to set verbosity to 0' }, # verbose => { # in => 0, # out => 0, # test_name => '... and we should be able to set verbose to false' # }, }, { switches => { in => [ '-T', '-w', '-T' ], out => [ '-T', '-w', '-T' ], test_name => '... duplicate switches should remain', }, failures => { in => 1, out => 1, test_name => '... and we should be able to set failures to true', }, verbosity => { in => -1, out => -1, test_name => '... and we should be able to set verbosity to -1' }, # quiet => { # in => 1, # out => 1, # test_name => '... and we should be able to set quiet to false' # }, }, { verbosity => { in => -2, out => -2, test_name => '... and we should be able to set verbosity to -2' }, # really_quiet => { # in => 1, # out => 1, # test_name => # '... and we should be able to set really_quiet to true', # }, exec => { in => $^X, out => $^X, test_name => '... and we should be able to set the executable', }, }, { switches => { in => 'T', out => ['T'], test_name => '... leading dashes (-) on switches are not optional', }, }, { switches => { in => '-T', out => ['-T'], test_name => '... we should be able to set switches', }, failures => { in => 1, out => 1, test_name => '... and we should be able to set failures to true' }, }; } sub _runtests { my ( $harness, @tests ) = @_; local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; my $aggregate = $harness->runtests(@tests); return $aggregate; } { # coverage tests for ctor my $harness = TAP::Harness->new( { timer => 0, errors => 1, merge => 2, # formatter => 3, } ); is $harness->timer(), 0, 'timer getter'; is $harness->timer(10), 10, 'timer setter'; is $harness->errors(), 1, 'errors getter'; is $harness->errors(10), 10, 'errors setter'; is $harness->merge(), 2, 'merge getter'; is $harness->merge(10), 10, 'merge setter'; # jobs accessor is $harness->jobs(), 1, 'jobs'; } { # coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor { # ref $ref => false my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; my $harness = TAP::Harness->new( { stdout => bless {}, '0', # how evil is THAT !!! } ); }; is @die, 1, 'bad filehandle to stdout'; like pop @die, qr/option 'stdout' needs a filehandle/, '... and we died as expected'; } { # ref => ! GLOB and ref->can(print) package Printable; sub new { return bless {}, shift } sub print {return} package main; my $harness = TAP::Harness->new( { stdout => Printable->new(), } ); isa_ok $harness, 'TAP::Harness'; } { # ref $ref => GLOB my $harness = TAP::Harness->new( { stdout => bless {}, 'GLOB', # again with the evil } ); isa_ok $harness, 'TAP::Harness'; } { # bare glob my $harness = TAP::Harness->new( { stdout => *STDOUT } ); isa_ok $harness, 'TAP::Harness'; } { # string filehandle my $string = ''; open my $fh, ">", \$string or die $!; my $harness = TAP::Harness->new( { stdout => $fh } ); isa_ok $harness, 'TAP::Harness'; } { # lexical filehandle reference my $string = ''; open my $fh, ">", \$string or die $!; ok !eval { TAP::Harness->new( { stdout => \$fh } ); }; like $@, qr/^option 'stdout' needs a filehandle /; } } { # coverage testing of lib/switches accessor my $harness = TAP::Harness->new; my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $harness->switches(qw( too many arguments)); }; is @die, 1, 'too many arguments to accessor'; like pop @die, qr/Too many arguments to method 'switches'/, '...and we died as expected'; $harness->switches('simple scalar'); my $arrref = $harness->switches; is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref'; } { # coverage tests for the basically untested T::H::_open_spool my @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 # a cleanup hook END { use File::Path; # remove the tree if we made it this far rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) if $ENV{PERL_TEST_HARNESS_DUMP_TAP}; } my $harness = TAP::Harness->new( { verbosity => -2 } ); can_ok $harness, 'runtests'; # normal tests in verbose mode my $parser = $harness->runtests( File::Spec->catfile( $source_tests, 'harness' ) ); isa_ok $parser, 'TAP::Parser::Aggregator', '... runtests returns the aggregate'; ok -e File::Spec->catfile( $ENV{PERL_TEST_HARNESS_DUMP_TAP}, $source_tests, 'harness' ); } { # test name munging my @cases = ( { name => 'all the same', input => [ 'foo.t', 'bar.t', 'fletz.t' ], output => [ [ 'foo.t', 'foo.t' ], [ 'bar.t', 'bar.t' ], [ 'fletz.t', 'fletz.t' ] ], }, { name => 'all the same, already cooked', input => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ], output => [ [ 'foo.t', 'foo.t' ], [ 'bar.t', 'brip' ], [ 'fletz.t', 'fletz.t' ] ], }, { name => 'different exts', input => [ 'foo.t', 'bar.u', 'fletz.v' ], output => [ [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bar.u' ], [ 'fletz.v', 'fletz.v' ] ], }, { name => 'different exts, one already cooked', input => [ 'foo.t', [ 'bar.u', 'bam' ], 'fletz.v' ], output => [ [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam' ], [ 'fletz.v', 'fletz.v' ] ], }, { name => 'different exts, two already cooked', input => [ 'foo.t', [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ], output => [ [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ], }, ); for my $case (@cases) { is_deeply [ TAP::Harness->_add_descriptions( @{ $case->{input} } ) ], $case->{output}, '_add_descriptions: ' . $case->{name}; } } Test-Harness-3.36/t/sample-tests/0000755000175000017500000000000012640746441015335 5ustar leonleonTest-Harness-3.36/t/sample-tests/skip_nomsg0000644000175000017500000000004612166360606017427 0ustar leonleonprint < 1; ok 23, 42; Test-Harness-3.36/t/sample-tests/out_err_mix0000644000175000017500000000034712166360606017616 0ustar leonleonsub _autoflush { my $flushed = shift; my $old_fh = select $flushed; $| = 1; select $old_fh; } _autoflush( \*STDOUT ); _autoflush( \*STDERR ); print STDOUT "one\n"; print STDERR "two\n\n"; print STDOUT "three\n"; Test-Harness-3.36/t/sample-tests/head_fail0000644000175000017500000000016512166360606017154 0ustar leonleonprint < 1; ok( grep( /examples/, @INC ) ); Test-Harness-3.36/t/sample-tests/version_old0000644000175000017500000000011412166360606017575 0ustar leonleonprint <>= 1; print shift @parts; } sleep $delay if ( $delay_at & 1 ); Test-Harness-3.36/t/sample-tests/space_after_plan0000644000175000017500000000016712166360606020550 0ustar leonleon# gforth TAP generates a space after the plan. Should probably be allowed. print "1..5 \n"; print "ok $_ \n" for 1..5; Test-Harness-3.36/t/sample-tests/taint_warn0000644000175000017500000000034212166360606017423 0ustar leonleon#!/usr/bin/perl -tw use lib qw(t/lib); use Test::More tests => 1; my $warnings = ''; { local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; `$^X -e1`; } like( $warnings, '/^Insecure dependency/', '-t honored' ); Test-Harness-3.36/t/sample-tests/taint0000644000175000017500000000021412166360606016372 0ustar leonleon#!/usr/bin/perl -Tw use lib qw(t/lib); use Test::More tests => 1; eval { `$^X -e1` }; like( $@, '/^Insecure dependency/', '-T honored' ); Test-Harness-3.36/t/sample-tests/descriptive0000644000175000017500000000025012166360606017574 0ustar leonleonprint < \\ ok 2 Not a continuation line DUMMY_TEST Test-Harness-3.36/t/sample-tests/die_last_minute0000644000175000017500000000015712166360606020426 0ustar leonleonprint < 'Hello World', in => [ '--- Hello, World', '...', ], out => "Hello, World", }, { name => 'Hello World 2', in => [ '--- \'Hello, \'\'World\'', '...', ], out => "Hello, 'World", }, { name => 'Hello World 3', in => [ '--- "Hello, World"', '...', ], out => "Hello, World", }, { name => 'Hello World 4', in => [ '--- "Hello, World"', '...', ], out => "Hello, World", }, { name => 'Hello World 4', in => [ '--- >', ' Hello,', ' World', '...', ], out => "Hello, World\n", }, { name => 'Hello World Block', in => [ '--- |', ' Hello,', ' World', '...', ], out => "Hello,\n World\n", }, { name => 'Hello World 5', in => [ '--- >', ' Hello,', ' World', '...', ], error => qr{Missing\s+'[.][.][.]'}, }, { name => 'Simple array', in => [ '---', '- 1', '- 2', '- 3', '...', ], out => [ '1', '2', '3' ], }, { name => 'Mixed array', in => [ '---', '- 1', '- \'two\'', '- "three\n"', '...', ], out => [ '1', 'two', "three\n" ], }, { name => 'Hash in array', in => [ '---', '- 1', '- two: 2', '- 3', '...', ], out => [ '1', { two => '2' }, '3' ], }, { name => 'Hash in array 2', in => [ '---', '- 1', '- two: 2', ' three: 3', '- 4', '...', ], out => [ '1', { two => '2', three => '3' }, '4' ], }, { name => 'Nested array', in => [ '---', '- one', '-', ' - two', ' -', ' - three', ' - four', '- five', '...', ], out => [ 'one', [ 'two', ['three'], 'four' ], 'five' ], }, { name => 'Nested hash', in => [ '---', 'one:', ' five: 5', ' two:', ' four: 4', ' three: 3', 'six: 6', '...', ], out => { one => { two => { three => '3', four => '4' }, five => '5' }, six => '6' }, }, { name => 'Space after colon', in => [ '---', 'spog: ', ' - 1', ' - 2', '...' ], out => { spog => [ 1, 2 ] }, }, { name => 'Original YAML::Tiny test', in => [ '---', 'invoice: 34843', 'date : 2001-01-23', 'bill-to:', ' given : Chris', ' family : Dumars', ' address:', ' lines: |', ' 458 Walkman Dr.', ' Suite #292', ' city : Royal Oak', ' state : MI', ' postal : 48046', 'product:', ' - sku : BL394D', ' quantity : 4', ' description : Basketball', ' price : 450.00', ' - sku : BL4438H', ' quantity : 1', ' description : Super Hoop', ' price : 2392.00', 'tax : 251.42', 'total: 4443.52', 'comments: >', ' Late afternoon is best.', ' Backup contact is Nancy', ' Billsmer @ 338-4338', '...', ], out => { 'bill-to' => { 'given' => 'Chris', 'address' => { 'city' => 'Royal Oak', 'postal' => '48046', 'lines' => "458 Walkman Dr.\nSuite #292\n", 'state' => 'MI' }, 'family' => 'Dumars' }, 'invoice' => '34843', 'date' => '2001-01-23', 'tax' => '251.42', 'product' => [ { 'sku' => 'BL394D', 'quantity' => '4', 'price' => '450.00', 'description' => 'Basketball' }, { 'sku' => 'BL4438H', 'quantity' => '1', 'price' => '2392.00', 'description' => 'Super Hoop' } ], 'comments' => "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", 'total' => '4443.52' } }, # Tests harvested from YAML::Tiny { in => ['...'], name => 'Regression: empty', error => qr{document\s+header\s+not\s+found} }, { in => [ '# comment', '...' ], name => 'Regression: only_comment', error => qr{document\s+header\s+not\s+found} }, { out => undef, in => [ '---', '...' ], name => 'Regression: only_header', error => qr{Premature\s+end}i, }, { out => undef, in => [ '---', '---', '...' ], name => 'Regression: two_header', error => qr{Unexpected\s+start}i, }, { out => undef, in => [ '--- ~', '...' ], name => 'Regression: one_undef' }, { out => undef, in => [ '--- ~', '...' ], name => 'Regression: one_undef2' }, { in => [ '--- ~', '---', '...' ], name => 'Regression: two_undef', error => qr{Missing\s+'[.][.][.]'}, }, { out => 'foo', in => [ '--- foo', '...' ], name => 'Regression: one_scalar', }, { out => 'foo', in => [ '--- foo', '...' ], name => 'Regression: one_scalar2', }, { in => [ '--- foo', '--- bar', '...' ], name => 'Regression: two_scalar', error => qr{Missing\s+'[.][.][.]'}, }, { out => ['foo'], in => [ '---', '- foo', '...' ], name => 'Regression: one_list1' }, { out => [ 'foo', 'bar' ], in => [ '---', '- foo', '- bar', '...' ], name => 'Regression: one_list2' }, { out => [ undef, 'bar' ], in => [ '---', '- ~', '- bar', '...' ], name => 'Regression: one_listundef' }, { out => { 'foo' => 'bar' }, in => [ '---', 'foo: bar', '...' ], name => 'Regression: one_hash1' }, { out => { 'foo' => 'bar', 'this' => undef }, in => [ '---', 'foo: bar', 'this: ~', '...' ], name => 'Regression: one_hash2' }, { out => { 'foo' => [ 'bar', undef, 'baz' ] }, in => [ '---', 'foo:', ' - bar', ' - ~', ' - baz', '...' ], name => 'Regression: array_in_hash' }, { out => { 'bar' => { 'foo' => 'bar' }, 'foo' => undef }, in => [ '---', 'foo: ~', 'bar:', ' foo: bar', '...' ], name => 'Regression: hash_in_hash' }, { out => [ { 'foo' => undef, 'this' => 'that' }, 'foo', undef, { 'foo' => 'bar', 'this' => 'that' } ], in => [ '---', '-', ' foo: ~', ' this: that', '- foo', '- ~', '-', ' foo: bar', ' this: that', '...' ], name => 'Regression: hash_in_array' }, { out => ['foo'], in => [ '---', '- \'foo\'', '...' ], name => 'Regression: single_quote1' }, { out => [' '], in => [ '---', '- \' \'', '...' ], name => 'Regression: single_spaces' }, { out => [''], in => [ '---', '- \'\'', '...' ], name => 'Regression: single_null' }, { out => ' ', in => [ '--- " "', '...' ], name => 'Regression: only_spaces' }, { out => ['first','second'], in => [ '--- ', '- first ', '- second ', '...' ], name => "Space after header for array", }, { out => {'key' => [{'value' => {'key2' => 'value2'}}]}, in => [ '--- ', 'key: ', '- value: ', ' key2: value2 ', '... ' ], name => "Space after header for hash", }, { out => [ undef, { 'foo' => 'bar', 'this' => 'that' }, 'baz' ], in => [ '---', '- ~', '- foo: bar', ' this: that', '- baz', '...' ], name => 'Regression: inline_nested_hash' }, { name => "Unprintables", in => [ "---", "- \"\\z\\x01\\x02\\x03\\x04\\x05\\x06\\a\\x08\\t\\n\\v\\f\\r\\x0e\\x0f\"", "- \"\\x10\\x11\\x12\\x13\\x14\\x15\\x16\\x17\\x18\\x19\\x1a\\e\\x1c\\x1d\\x1e\\x1f\"", "- \" !\\\"#\$%&'()*+,-./\"", "- 0123456789:;<=>?", "- '\@ABCDEFGHIJKLMNO'", "- 'PQRSTUVWXYZ[\\]^_'", "- '`abcdefghijklmno'", "- 'pqrstuvwxyz{|}~\177'", "- \200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", "- \220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", "- \240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", "- \260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", "- \300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", "- \320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", "- \340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", "- \360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377", "..." ], out => [ "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17", "\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37", " !\"#\$%&'()*+,-./", "0123456789:;<=>?", "\@ABCDEFGHIJKLMNO", "PQRSTUVWXYZ[\\]^_", "`abcdefghijklmno", "pqrstuvwxyz{|}~\177", "\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", "\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", "\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", "\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", "\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", "\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", "\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", "\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377" ], }, { name => 'Quoted hash keys', in => [ '---', ' "quoted": Magic!', ' "\n\t": newline, tab', '...', ], out => { quoted => 'Magic!', "\n\t" => 'newline, tab', }, }, { name => 'Empty', in => [], out => undef, }, ); plan tests => @SCHEDULE * 5; } sub iter { my $ar = shift; return sub { return shift @$ar; }; } for my $test (@SCHEDULE) { my $name = $test->{name}; ok my $yaml = TAP::Parser::YAMLish::Reader->new, "$name: Created"; isa_ok $yaml, 'TAP::Parser::YAMLish::Reader'; my $source = join( "\n", @{ $test->{in} } ) . "\n"; my $iter = iter( $test->{in} ); my $got = eval { $yaml->read($iter) }; my $raw = $yaml->get_raw; if ( my $err = $test->{error} ) { unless ( like $@, $err, "$name: Error message" ) { diag "Error: $@\n"; } ok !$got, "$name: No result"; pass; } else { my $want = $test->{out}; unless ( ok !$@, "$name: No error" ) { diag "Error: $@\n"; } is_deeply $got, $want, "$name: Result matches"; is $raw, $source, "$name: Captured source matches"; } } Test-Harness-3.36/t/prove.t0000644000175000017500000013205112426525255014236 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More; use File::Spec; use App::Prove; use Getopt::Long; use Text::ParseWords qw(shellwords); package FakeProve; use base qw( App::Prove ); sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->{_log} = []; return $self; } sub _color_default {0} sub _runtests { my $self = shift; push @{ $self->{_log} }, [ '_runtests', @_ ]; } sub get_log { my $self = shift; my @log = @{ $self->{_log} }; $self->{_log} = []; return @log; } sub _shuffle { my $self = shift; s/^/xxx/ for @_; } package main; sub mabs { my $ar = shift; return [ map { File::Spec->rel2abs($_) } @$ar ]; } { my @import_log = (); sub test_log_import { push @import_log, [@_] } sub get_import_log { my @log = @import_log; @import_log = (); return @log; } my @plugin_load_log = (); sub test_log_plugin_load { push @plugin_load_log, [@_] } sub get_plugin_load_log { my @log = @plugin_load_log; @plugin_load_log = (); return @log; } } my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE, $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( archive argv blib color directives exec extensions failures formatter harness includes lib merge parse quiet really_quiet recurse backwards shuffle taint_fail taint_warn verbose warnings_fail warnings_warn ); # what we expect if the 'expect' hash does not define it %DEFAULT_ASSERTION = map { $_ => undef } @ATTR; $DEFAULT_ASSERTION{includes} = $DEFAULT_ASSERTION{argv} = sub { 'ARRAY' eq ref shift }; my @dummy_tests = map { File::Spec->catdir( 't', 'sample-tests', $_ ) } qw(simple simple_yaml); my $dummy_test = $dummy_tests[0]; ######################################################################## # declarations - this drives all of the subtests. # The cheatsheet follows. # required: name, expect # optional: # args - arguments to constructor # switches - command-line switches # runlog - expected results of internal calls to _runtests, must # match FakeProve's _log attr # run_error - depends on 'runlog' (if missing, asserts no error) # extra - follow-up check to handle exceptional cleanup / verification # class - The App::Prove subclass to test. Defaults to FakeProve @SCHEDULE = ( { name => 'Create empty', expect => {} }, { name => 'Set all options via constructor', args => { archive => 1, argv => [qw(one two three)], blib => 2, color => 3, directives => 4, exec => 5, failures => 7, formatter => 8, harness => 9, includes => [qw(four five six)], lib => 10, merge => 11, parse => 13, quiet => 14, really_quiet => 15, recurse => 16, backwards => 17, shuffle => 18, taint_fail => 19, taint_warn => 20, verbose => 21, warnings_fail => 22, warnings_warn => 23, }, expect => { archive => 1, argv => [qw(one two three)], blib => 2, color => 3, directives => 4, exec => 5, failures => 7, formatter => 8, harness => 9, includes => [qw(four five six)], lib => 10, merge => 11, parse => 13, quiet => 14, really_quiet => 15, recurse => 16, backwards => 17, shuffle => 18, taint_fail => 19, taint_warn => 20, verbose => 21, warnings_fail => 22, warnings_warn => 23, } }, { name => 'Call with defaults', args => { argv => [qw( one two three )] }, expect => {}, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, # Test all options individually # { name => 'Just archive', # args => { # argv => [qw( one two three )], # archive => 1, # }, # expect => { # archive => 1, # }, # runlog => [ # [ { archive => 1, # }, # 'one', 'two', # 'three' # ] # ], # }, { name => 'Just argv', args => { argv => [qw( one two three )], }, expect => { argv => [qw( one two three )], }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1 }, 'one', 'two', 'three' ] ], }, { name => 'Just blib', args => { argv => [qw( one two three )], blib => 1, }, expect => { blib => 1, }, runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just color', args => { argv => [qw( one two three )], color => 1, }, expect => { color => 1, }, runlog => [ [ '_runtests', { color => 1, verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just directives', args => { argv => [qw( one two three )], directives => 1, }, expect => { directives => 1, }, runlog => [ [ '_runtests', { directives => 1, verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just exec', args => { argv => [qw( one two three )], exec => 1, }, expect => { exec => 1, }, runlog => [ [ '_runtests', { exec => [1], verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just failures', args => { argv => [qw( one two three )], failures => 1, }, expect => { failures => 1, }, runlog => [ [ '_runtests', { failures => 1, verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just formatter', args => { argv => [qw( one two three )], formatter => 'TAP::Harness', }, expect => { formatter => 'TAP::Harness', }, runlog => [ [ '_runtests', { formatter_class => 'TAP::Harness', verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just includes', args => { argv => [qw( one two three )], includes => [qw( four five six )], }, expect => { includes => [qw( four five six )], }, runlog => [ [ '_runtests', { lib => mabs( [qw( four five six )] ), verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just lib', args => { argv => [qw( one two three )], lib => 1, }, expect => { lib => 1, }, runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just merge', args => { argv => [qw( one two three )], merge => 1, }, expect => { merge => 1, }, runlog => [ [ '_runtests', { merge => 1, verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just parse', args => { argv => [qw( one two three )], parse => 1, }, expect => { parse => 1, }, runlog => [ [ '_runtests', { errors => 1, verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just quiet', args => { argv => [qw( one two three )], quiet => 1, }, expect => { quiet => 1, }, runlog => [ [ '_runtests', { verbosity => -1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just really_quiet', args => { argv => [qw( one two three )], really_quiet => 1, }, expect => { really_quiet => 1, }, runlog => [ [ '_runtests', { verbosity => -2, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just recurse', args => { argv => [qw( one two three )], recurse => 1, }, expect => { recurse => 1, }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just reverse', args => { argv => [qw( one two three )], backwards => 1, }, expect => { backwards => 1, }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'three', 'two', 'one' ] ], }, { name => 'Just shuffle', args => { argv => [qw( one two three )], shuffle => 1, }, expect => { shuffle => 1, }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'xxxone', 'xxxtwo', 'xxxthree' ] ], }, { name => 'Just taint_fail', args => { argv => [qw( one two three )], taint_fail => 1, }, expect => { taint_fail => 1, }, runlog => [ [ '_runtests', { switches => ['-T'], verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just taint_warn', args => { argv => [qw( one two three )], taint_warn => 1, }, expect => { taint_warn => 1, }, runlog => [ [ '_runtests', { switches => ['-t'], verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just verbose', args => { argv => [qw( one two three )], verbose => 1, }, expect => { verbose => 1, }, runlog => [ [ '_runtests', { verbosity => 1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just warnings_fail', args => { argv => [qw( one two three )], warnings_fail => 1, }, expect => { warnings_fail => 1, }, runlog => [ [ '_runtests', { switches => ['-W'], verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just warnings_warn', args => { argv => [qw( one two three )], warnings_warn => 1, }, expect => { warnings_warn => 1, }, runlog => [ [ '_runtests', { switches => ['-w'], verbosity => 0, show_count => 1, }, 'one', 'two', 'three' ] ], }, # Command line parsing { name => 'Switch -v', args => { argv => [qw( one two three )], }, switches => [ '-v', $dummy_test ], expect => { verbose => 1, }, runlog => [ [ '_runtests', { verbosity => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --verbose', args => { argv => [qw( one two three )], }, switches => [ '--verbose', $dummy_test ], expect => { verbose => 1, }, runlog => [ [ '_runtests', { verbosity => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -f', args => { argv => [qw( one two three )], }, switches => [ '-f', $dummy_test ], expect => { failures => 1 }, runlog => [ [ '_runtests', { failures => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --failures', args => { argv => [qw( one two three )], }, switches => [ '--failures', $dummy_test ], expect => { failures => 1 }, runlog => [ [ '_runtests', { failures => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -l', args => { argv => [qw( one two three )], }, switches => [ '-l', $dummy_test ], expect => { lib => 1 }, runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --lib', args => { argv => [qw( one two three )], }, switches => [ '--lib', $dummy_test ], expect => { lib => 1 }, runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -b', args => { argv => [qw( one two three )], }, switches => [ '-b', $dummy_test ], expect => { blib => 1 }, runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --blib', args => { argv => [qw( one two three )], }, switches => [ '--blib', $dummy_test ], expect => { blib => 1 }, runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -s', args => { argv => [qw( one two three )], }, switches => [ '-s', $dummy_test ], expect => { shuffle => 1 }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, "xxx$dummy_test" ] ], }, { name => 'Switch --shuffle', args => { argv => [qw( one two three )], }, switches => [ '--shuffle', $dummy_test ], expect => { shuffle => 1 }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, "xxx$dummy_test" ] ], }, { name => 'Switch -c', args => { argv => [qw( one two three )], }, switches => [ '-c', $dummy_test ], expect => { color => 1 }, runlog => [ [ '_runtests', { color => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -r', args => { argv => [qw( one two three )], }, switches => [ '-r', $dummy_test ], expect => { recurse => 1 }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --recurse', args => { argv => [qw( one two three )], }, switches => [ '--recurse', $dummy_test ], expect => { recurse => 1 }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --reverse', args => { argv => [qw( one two three )], }, switches => [ '--reverse', @dummy_tests ], expect => { backwards => 1 }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, reverse @dummy_tests ] ], }, { name => 'Switch -p', args => { argv => [qw( one two three )], }, switches => [ '-p', $dummy_test ], expect => { parse => 1, }, runlog => [ [ '_runtests', { errors => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --parse', args => { argv => [qw( one two three )], }, switches => [ '--parse', $dummy_test ], expect => { parse => 1, }, runlog => [ [ '_runtests', { errors => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -q', args => { argv => [qw( one two three )], }, switches => [ '-q', $dummy_test ], expect => { quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --quiet', args => { argv => [qw( one two three )], }, switches => [ '--quiet', $dummy_test ], expect => { quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -Q', args => { argv => [qw( one two three )], }, switches => [ '-Q', $dummy_test ], expect => { really_quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -2, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --QUIET', args => { argv => [qw( one two three )], }, switches => [ '--QUIET', $dummy_test ], expect => { really_quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -2, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -m', args => { argv => [qw( one two three )], }, switches => [ '-m', $dummy_test ], expect => { merge => 1 }, runlog => [ [ '_runtests', { merge => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --merge', args => { argv => [qw( one two three )], }, switches => [ '--merge', $dummy_test ], expect => { merge => 1 }, runlog => [ [ '_runtests', { merge => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --directives', args => { argv => [qw( one two three )], }, switches => [ '--directives', $dummy_test ], expect => { directives => 1 }, runlog => [ [ '_runtests', { directives => 1, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, # .proverc { name => 'Empty exec in .proverc', args => { argv => [qw( one two three )], }, proverc => 't/proverc/emptyexec', switches => [$dummy_test], expect => { exec => '' }, runlog => [ [ '_runtests', { exec => [], verbosity => 0, show_count => 1, }, $dummy_test ] ], }, # Executing one word (why would it be a -s though?) { name => 'Switch --exec -s', args => { argv => [qw( one two three )], }, switches => [ '--exec', '-s', $dummy_test ], expect => { exec => '-s' }, runlog => [ [ '_runtests', { exec => ['-s'], verbosity => 0, show_count => 1, }, $dummy_test ] ], }, # multi-part exec { name => 'Switch --exec "/foo/bar/perl -Ilib"', args => { argv => [qw( one two three )], }, switches => [ '--exec', '/foo/bar/perl -Ilib', $dummy_test ], expect => { exec => '/foo/bar/perl -Ilib' }, runlog => [ [ '_runtests', { exec => [qw(/foo/bar/perl -Ilib)], verbosity => 0, show_count => 1, }, $dummy_test ] ], }, # null exec (run tests as compiled binaries) { name => 'Switch --exec ""', switches => [ '--exec', '', $dummy_test ], expect => { exec => # ick, must workaround the || default bit with a sub sub { my $val = shift; defined($val) and !length($val) } }, runlog => [ [ '_runtests', { exec => [], verbosity => 0, show_count => 1, }, $dummy_test ] ], }, # Specify an oddball extension { name => 'Switch --ext=.wango', switches => ['--ext=.wango'], expect => { extensions => ['.wango'] }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, ] ], }, # Handle multiple extensions { name => 'Switch --ext=.foo --ext=.bar', switches => [ '--ext=.foo', '--ext=.bar', ], expect => { extensions => [ '.foo', '.bar' ] }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, ] ], }, # 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, }, $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', '--file-option', 'hash=this=that', '--file-option', 'hash=foo=bar', '--file-option', 'sep=foo\\=bar', $dummy_test ], expect => { sources => { Perl => { foo => 'bar baz', avg => 0.278 }, MyCustom => {}, File => { extensions => [ '.txt', '.tmp' ], hash => { this => 'that', foo => 'bar' }, sep => 'foo=bar', }, }, }, runlog => [ [ '_runtests', { sources => { Perl => { foo => 'bar baz', avg => 0.278 }, MyCustom => {}, File => { extensions => [ '.txt', '.tmp' ], hash => { this => 'that', foo => 'bar' }, sep => 'foo=bar', }, }, verbosity => 0, show_count => 1, }, $dummy_test ] ], }, # Plugins { name => 'Load plugin', switches => [ '-P', 'Dummy', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_import_log(); is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], "Plugin loaded OK"; }, plan => 1, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Load plugin (args)', switches => [ '-P', 'Dummy=cracking,cheese,gromit', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_import_log(); is_deeply \@loaded, [ [ 'App::Prove::Plugin::Dummy', 'cracking', 'cheese', 'gromit' ] ], "Plugin loaded OK"; }, plan => 1, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Load plugin (explicit path)', switches => [ '-P', 'App::Prove::Plugin::Dummy', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_import_log(); is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], "Plugin loaded OK"; }, plan => 1, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Load plugin (args + call load method)', switches => [ '-P', 'Dummy2=fou,du,fafa', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy2'], }, extra => sub { my @import = get_import_log(); is_deeply \@import, [ [ 'App::Prove::Plugin::Dummy2', 'fou', 'du', 'fafa' ] ], "Plugin loaded OK"; my @loaded = get_plugin_load_log(); is( scalar @loaded, 1, 'Plugin->load called OK' ); my ( $plugin_class, $args ) = @{ shift @loaded }; is( $plugin_class, 'App::Prove::Plugin::Dummy2', 'plugin_class passed' ); isa_ok( $args->{app_prove}, 'App::Prove', 'app_prove object passed' ); is_deeply( $args->{args}, [qw( fou du fafa )], 'expected args passed' ); }, plan => 5, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, $dummy_test ] ], }, { name => 'Load module', switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_import_log(); is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], "Plugin loaded OK"; }, plan => 1, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, $dummy_test ] ], }, # TODO # Hmm, that doesn't work... # { name => 'Switch -h', # args => { # argv => [qw( one two three )], # }, # switches => [ '-h', $dummy_test ], # expect => {}, # runlog => [ # [ '_runtests', # {}, # $dummy_test # ] # ], # }, # { name => 'Switch --help', # args => { # argv => [qw( one two three )], # }, # switches => [ '--help', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # { name => 'Switch -?', # args => { # argv => [qw( one two three )], # }, # switches => [ '-?', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch -H', # args => { # argv => [qw( one two three )], # }, # switches => [ '-H', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --man', # args => { # argv => [qw( one two three )], # }, # switches => [ '--man', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch -V', # args => { # argv => [qw( one two three )], # }, # switches => [ '-V', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --version', # args => { # argv => [qw( one two three )], # }, # switches => [ '--version', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --color!', # args => { # argv => [qw( one two three )], # }, # switches => [ '--color!', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # { name => 'Switch -I=s@', args => { argv => [qw( one two three )], }, switches => [ '-Ilib', $dummy_test ], expect => { includes => sub { my ( $val, $attr ) = @_; return 'ARRAY' eq ref $val && 1 == @$val && $val->[0] =~ /lib$/; }, }, }, # { name => 'Switch -a', # args => { # argv => [qw( one two three )], # }, # switches => [ '-a', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --archive=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--archive=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --formatter=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--formatter=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch -e', # args => { # argv => [qw( one two three )], # }, # switches => [ '-e', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --harness=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--harness=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, ); # END SCHEDULE ######################################################################## my $extra_plan = 0; for my $test (@SCHEDULE) { 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; } # END PLAN # ACTUAL TEST for my $test (@SCHEDULE) { my $name = $test->{name}; my $class = $test->{class} || 'FakeProve'; SKIP: { skip $test->{skip_reason}, $test->{_planned} if $test->{skip}; local $ENV{HARNESS_TIMER}; ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ), "$name: App::Prove created OK"; isa_ok $app, 'App::Prove'; isa_ok $app, $class; # 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"; } unless ($is_ok) { diag "got $val for $attr"; } } 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); } # adapt our expectations if HARNESS_PERL_SWITCHES is set push @{ $runlog->[0][1]{switches} }, shellwords( $ENV{HARNESS_PERL_SWITCHES} ) if $ENV{HARNESS_PERL_SWITCHES}; unless ( is_deeply $gotlog, $runlog, "$name: run results match" ) { use Data::Dumper; diag Dumper( { wanted => $runlog, got => $gotlog } ); } } } } # SKIP } Test-Harness-3.36/t/process.t0000644000175000017500000000176712426525633014572 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; my $hires; BEGIN { $hires = eval 'use Time::HiRes qw(sleep); 1'; } use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : $hires ? ( tests => 9 * 3 ) : ( skip_all => 'Need Time::HiRes' ) ); use File::Spec; use TAP::Parser::Iterator::Process; my @expect = ( '1..5', 'ok 1 00000', 'ok 2', 'not ok 3', 'ok 4', 'ok 5 00000', ); my $source = File::Spec->catfile( 't', 'sample-tests', 'delayed' ); for my $chunk_size ( 1, 4, 65536 ) { for my $where ( 0 .. 8 ) { my $proc = TAP::Parser::Iterator::Process->new( { _chunk_size => $chunk_size, command => [ $^X, $source, ( 1 << $where ) ] } ); my @got = (); while ( defined( my $line = $proc->next_raw ) ) { push @got, $line; } is_deeply \@got, \@expect, "I/O ok with delay at position $where, chunk size $chunk_size"; } } Test-Harness-3.36/t/results.t0000644000175000017500000001727012426525260014605 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 227; use TAP::Parser::ResultFactory; use TAP::Parser::Result; use constant RESULT => 'TAP::Parser::Result'; use constant PLAN => 'TAP::Parser::Result::Plan'; use constant TEST => 'TAP::Parser::Result::Test'; use constant COMMENT => 'TAP::Parser::Result::Comment'; use constant BAILOUT => 'TAP::Parser::Result::Bailout'; use constant UNKNOWN => 'TAP::Parser::Result::Unknown'; my $warning; $SIG{__WARN__} = sub { $warning = shift }; # # Note that the are basic unit tests. More comprehensive path coverage is # found in the regression tests. # my $factory = TAP::Parser::ResultFactory->new; my %inherited_methods = ( is_plan => '', is_test => '', is_comment => '', is_bailout => '', is_unknown => '', is_ok => 1, ); my $abstract_class = bless { type => 'no_such_type' }, RESULT; # you didn't see this run_method_tests( $abstract_class, {} ); # check the defaults can_ok $abstract_class, 'type'; is $abstract_class->type, 'no_such_type', '... and &type should return the correct result'; can_ok $abstract_class, 'passed'; $warning = ''; ok $abstract_class->passed, '... and it should default to true'; like $warning, qr/^\Qpassed() is deprecated. Please use "is_ok()"/, '... but it should emit a deprecation warning'; can_ok RESULT, 'new'; can_ok $factory, 'make_result'; eval { $factory->make_result( { type => 'no_such_type' } ) }; ok my $error = $@, '... and calling it with an unknown class should fail'; like $error, qr/^Could not determine class for.*no_such_type/s, '... with an appropriate error message'; # register new Result types: can_ok $factory, 'class_for'; can_ok $factory, 'register_type'; { package MyResult; use strict; use warnings; our $VERSION; use base 'TAP::Parser::Result'; TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); } { my $r = eval { $factory->make_result( { type => 'my_type' } ) }; my $error = $@; isa_ok( $r, 'MyResult', 'register custom type' ); ok( !$error, '... and no error' ); } # # test unknown tokens # run_tests( { class => UNKNOWN, data => { type => 'unknown', raw => '... this line is junk ... ', }, }, { is_unknown => 1, raw => '... this line is junk ... ', as_string => '... this line is junk ... ', type => 'unknown', has_directive => '', } ); # # test comment tokens # run_tests( { class => COMMENT, data => { type => 'comment', raw => '# this is a comment', comment => 'this is a comment', }, }, { is_comment => 1, raw => '# this is a comment', as_string => '# this is a comment', comment => 'this is a comment', type => 'comment', has_directive => '', } ); # # test bailout tokens # run_tests( { class => BAILOUT, data => { type => 'bailout', raw => 'Bailout! This blows!', bailout => 'This blows!', }, }, { is_bailout => 1, raw => 'Bailout! This blows!', as_string => 'This blows!', type => 'bailout', has_directive => '', } ); # # test plan tokens # run_tests( { class => PLAN, data => { type => 'plan', raw => '1..20', tests_planned => 20, directive => '', explanation => '', }, }, { is_plan => 1, raw => '1..20', tests_planned => 20, directive => '', explanation => '', has_directive => '', } ); run_tests( { class => PLAN, data => { type => 'plan', raw => '1..0 # SKIP help me, Rhonda!', tests_planned => 0, directive => 'SKIP', explanation => 'help me, Rhonda!', }, }, { is_plan => 1, raw => '1..0 # SKIP help me, Rhonda!', tests_planned => 0, directive => 'SKIP', explanation => 'help me, Rhonda!', has_directive => 1, } ); # # test 'test' tokens # my $test = run_tests( { class => TEST, data => { ok => 'ok', test_num => 5, description => '... and this test is fine', directive => '', explanation => '', raw => 'ok 5 and this test is fine', type => 'test', }, }, { is_test => 1, type => 'test', ok => 'ok', number => 5, description => '... and this test is fine', directive => '', explanation => '', is_ok => 1, is_actual_ok => 1, todo_passed => '', has_skip => '', has_todo => '', as_string => 'ok 5 ... and this test is fine', is_unplanned => '', has_directive => '', } ); can_ok $test, 'actual_passed'; $warning = ''; is $test->actual_passed, $test->is_actual_ok, '... and it should return the correct value'; like $warning, qr/^\Qactual_passed() is deprecated. Please use "is_actual_ok()"/, '... but issue a deprecation warning'; can_ok $test, 'todo_failed'; $warning = ''; is $test->todo_failed, $test->todo_passed, '... and it should return the correct value'; like $warning, qr/^\Qtodo_failed() is deprecated. Please use "todo_passed()"/, '... but issue a deprecation warning'; # TODO directive $test = run_tests( { class => TEST, data => { ok => 'not ok', test_num => 5, description => '... and this test is fine', directive => 'TODO', explanation => 'why not?', raw => 'not ok 5 and this test is fine # TODO why not?', type => 'test', }, }, { is_test => 1, type => 'test', ok => 'not ok', number => 5, description => '... and this test is fine', directive => 'TODO', explanation => 'why not?', is_ok => 1, is_actual_ok => '', todo_passed => '', has_skip => '', has_todo => 1, as_string => 'not ok 5 ... and this test is fine # TODO why not?', is_unplanned => '', has_directive => 1, } ); sub run_tests { my ( $instantiated, $value_for ) = @_; my $result = instantiate($instantiated); run_method_tests( $result, $value_for ); return $result; } sub instantiate { my $instantiated = shift; my $class = $instantiated->{class}; ok my $result = $factory->make_result( $instantiated->{data} ), 'Creating $class results should succeed'; isa_ok $result, $class, '.. and the object it returns'; return $result; } sub run_method_tests { my ( $result, $value_for ) = @_; while ( my ( $method, $default ) = each %inherited_methods ) { can_ok $result, $method; if ( defined( my $value = delete $value_for->{$method} ) ) { is $result->$method(), $value, "... and $method should be correct"; } else { is $result->$method(), $default, "... and $method default should be correct"; } } while ( my ( $method, $value ) = each %$value_for ) { can_ok $result, $method; is $result->$method(), $value, "... and $method should be correct"; } } Test-Harness-3.36/t/data/0000755000175000017500000000000012640746441013625 5ustar leonleonTest-Harness-3.36/t/data/proverc0000644000175000017500000000017712166360606015233 0ustar leonleon--should be --split correctly # No comment! Can "quote things" 'using single or' "double quotes" # More stuff --this is 'OK?' Test-Harness-3.36/t/data/catme.10000644000175000017500000000001212166360606014767 0ustar leonleon1..1 ok 1 Test-Harness-3.36/t/data/sample.yml0000644000175000017500000000111412166360606015624 0ustar leonleon--- invoice: 34843 date : 2001-01-23 bill-to: given : Chris family : Dumars address: lines: | 458 Walkman Dr. Suite #292 city : Royal Oak state : MI postal : 48046 product: - sku : BL394D quantity : 4 description : Basketball price : 450.00 - sku : BL4438H quantity : 1 description : Super Hoop price : 2392.00 tax : 251.42 total: 4443.52 comments: > Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338 Test-Harness-3.36/t/nested.t0000644000175000017500000000153412426525261014363 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 5; use TAP::Parser; my $tap = <<'END_TAP'; 1..2 ok 1 - input file opened ... this is junk Bail out! We ran out of foobar. END_TAP my $parser = TAP::Parser->new( { tap => $tap } ); isa_ok $parser, 'TAP::Parser', '... we should be able to parse bailed out tests'; my @results; while ( my $result = $parser->next ) { push @results => $result; } my $bailout = pop @results; ok $bailout->is_bailout, 'We should be able to parse a nested bailout'; is $bailout->as_string, 'We ran out of foobar.', '... and as_string() should return the explanation'; is $bailout->raw, ' Bail out! We ran out of foobar.', '... and raw() should return the explanation'; is $bailout->explanation, 'We ran out of foobar.', '... and it should have the correct explanation'; Test-Harness-3.36/t/aggregator.t0000644000175000017500000002254612426525263015233 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 81; use TAP::Parser; use TAP::Parser::Iterator::Array; use TAP::Parser::Aggregator; my $tap = <<'END_TAP'; 1..5 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure ok 5 # skip we have no description END_TAP my $iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); isa_ok $iterator, 'TAP::Parser::Iterator'; my $parser1 = TAP::Parser->new( { iterator => $iterator } ); isa_ok $parser1, 'TAP::Parser'; $parser1->run; $tap = <<'END_TAP'; 1..7 ok 1 - gentlemen, start your engines not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure ok 5 ok 6 - you shall not pass! # TODO should have failed not ok 7 - Gandalf wins. Game over. # TODO 'bout time! END_TAP my $parser2 = TAP::Parser->new( { tap => $tap } ); isa_ok $parser2, 'TAP::Parser'; $parser2->run; can_ok 'TAP::Parser::Aggregator', 'new'; my $agg = TAP::Parser::Aggregator->new; isa_ok $agg, 'TAP::Parser::Aggregator'; can_ok $agg, 'add'; ok $agg->add( 'tap1', $parser1 ), '... and calling it should succeed'; ok $agg->add( 'tap2', $parser2 ), '... even if we add more than one parser'; eval { $agg->add( 'tap1', $parser1 ) }; like $@, qr/^You already have a parser for \Q(tap1)/, '... but trying to reuse a description should be fatal'; can_ok $agg, 'parsers'; is scalar $agg->parsers, 2, '... and it should report how many parsers it has'; is_deeply [ $agg->parsers ], [ $parser1, $parser2 ], '... or which parsers it has'; is_deeply $agg->parsers('tap2'), $parser2, '... or reporting a single parser'; is_deeply [ $agg->parsers(qw(tap2 tap1)) ], [ $parser2, $parser1 ], '... or a group'; # test aggregate results can_ok $agg, 'passed'; is $agg->passed, 10, '... and we should have the correct number of passed tests'; is_deeply [ $agg->passed ], [qw(tap1 tap2)], '... and be able to get their descriptions'; can_ok $agg, 'failed'; is $agg->failed, 2, '... and we should have the correct number of failed tests'; is_deeply [ $agg->failed ], [qw(tap1 tap2)], '... and be able to get their descriptions'; can_ok $agg, 'todo'; is $agg->todo, 4, '... and we should have the correct number of todo tests'; is_deeply [ $agg->todo ], [qw(tap1 tap2)], '... and be able to get their descriptions'; can_ok $agg, 'skipped'; is $agg->skipped, 1, '... and we should have the correct number of skipped tests'; is_deeply [ $agg->skipped ], [qw(tap1)], '... and be able to get their descriptions'; can_ok $agg, 'parse_errors'; is $agg->parse_errors, 0, '... and the correct number of parse errors'; is_deeply [ $agg->parse_errors ], [], '... and be able to get their descriptions'; can_ok $agg, 'todo_passed'; is $agg->todo_passed, 1, '... and the correct number of unexpectedly succeeded tests'; is_deeply [ $agg->todo_passed ], [qw(tap2)], '... and be able to get their descriptions'; can_ok $agg, 'total'; is $agg->total, $agg->passed + $agg->failed, '... and we should have the correct number of total tests'; can_ok $agg, 'planned'; is $agg->planned, $agg->passed + $agg->failed, '... and we should have the correct number of planned tests'; can_ok $agg, 'has_problems'; ok $agg->has_problems, '... and it should report true if there are problems'; can_ok $agg, 'has_errors'; ok $agg->has_errors, '... and it should report true if there are errors'; can_ok $agg, 'get_status'; is $agg->get_status, 'FAIL', '... and it should tell us the tests failed'; can_ok $agg, 'all_passed'; ok !$agg->all_passed, '... and it should tell us not all tests passed'; # coverage testing # _get_parsers # bad descriptions # currently the $agg object has descriptions tap1 and tap2 # call _get_parsers with another description. # $agg will call its _croak method my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $agg->_get_parsers('no_such_parser_for'); }; is @die, 1, 'coverage tests for missing parsers... and we caught just one death message'; like pop(@die), qr/^A parser for \(no_such_parser_for\) could not be found at /, '... and it was the expected death message'; # _get_parsers in scalar context my $gp = $agg->_get_parsers(qw(tap1 tap2)) ; # should return ref to array containing parsers for tap1 and tap2 is @$gp, 2, 'coverage tests for _get_parser in scalar context... and we got the right number of parsers'; isa_ok( $_, 'TAP::Parser' ) for (@$gp); # _get_parsers # todo_failed - this is a deprecated method, so it (and these tests) # can be removed eventually. However, it is showing up in the coverage # as never tested. my @warn; eval { local $SIG{__WARN__} = sub { push @warn, @_ }; $agg->todo_failed(); }; # check the warning, making sure to capture the fullstops correctly (not # as "any char" matches) is @warn, 1, 'coverage tests for deprecated todo_failed... and just one warning caught'; like pop(@warn), qr/^"todo_failed" is deprecated[.] Please use "todo_passed"[.] See the docs[.] at/, '... and it was the expected warning'; # has_problems # this has a large number of conditions 'OR'd together, so the tests get # a little complicated here # currently, we have covered the cases of failed() being true and none # of the summary methods failing # we need to set up test cases for # 1. !failed && todo_passed # 2. !failed && !todo_passed && parse_errors # 3. !failed && !todo_passed && !parse_errors && exit # 4. !failed && !todo_passed && !parse_errors && !exit && wait # note there is nothing wrong per se with the has_problems logic, these # are simply coverage tests # 1. !failed && todo_passed $agg = TAP::Parser::Aggregator->new(); isa_ok $agg, 'TAP::Parser::Aggregator'; $tap = <<'END_TAP'; 1..1 ok 1 - you shall not pass! # TODO should have failed END_TAP my $parser3 = TAP::Parser->new( { tap => $tap } ); isa_ok $parser3, 'TAP::Parser'; $parser3->run; $agg->add( 'tap3', $parser3 ); is $agg->passed, 1, 'coverage tests for !failed && todo_passed... and we should have the correct number of passed tests'; is $agg->failed, 0, '... and we should have the correct number of failed tests'; is $agg->todo_passed, 1, '... and the correct number of unexpectedly succeeded tests'; ok $agg->has_problems, '... and it should report true that there are problems'; is $agg->get_status, 'PASS', '... and the status should be passing'; ok !$agg->has_errors, '.... but it should not report any errors'; ok $agg->all_passed, '... bonus tests should be passing tests, too'; # 2. !failed && !todo_passed && parse_errors $agg = TAP::Parser::Aggregator->new(); $tap = <<'END_TAP'; 1..-1 END_TAP my $parser4 = TAP::Parser->new( { tap => $tap } ); isa_ok $parser4, 'TAP::Parser'; $parser4->run; $agg->add( 'tap4', $parser4 ); is $agg->passed, 0, 'coverage tests for !failed && !todo_passed && parse_errors... and we should have the correct number of passed tests'; is $agg->failed, 0, '... and we should have the correct number of failed tests'; is $agg->todo_passed, 0, '... and the correct number of unexpectedly succeeded tests'; is $agg->parse_errors, 1, '... and the correct number of parse errors'; ok $agg->has_problems, '... and it should report true that there are problems'; # 3. !failed && !todo_passed && !parse_errors && exit # now this is a little harder to emulate cleanly through creating tap # fragments and parsing, as exit and wait collect OS-status codes. # so we'll get a little funky with $agg and push exit and wait descriptions # in it - not very friendly to internal rep changes. $agg = TAP::Parser::Aggregator->new(); $tap = <<'END_TAP'; 1..1 ok 1 - you shall not pass! END_TAP my $parser5 = TAP::Parser->new( { tap => $tap } ); $parser5->run; $agg->add( 'tap', $parser5 ); push @{ $agg->{descriptions_for_exit} }, 'one possible reason'; $agg->{exit}++; is $agg->passed, 1, 'coverage tests for !failed && !todo_passed && !parse_errors... and we should have the correct number of passed tests'; is $agg->failed, 0, '... and we should have the correct number of failed tests'; is $agg->todo_passed, 0, '... and the correct number of unexpectedly succeeded tests'; is $agg->parse_errors, 0, '... and the correct number of parse errors'; my @exits = $agg->exit; is @exits, 1, '... and the correct number of exits'; is pop(@exits), 'one possible reason', '... and we collected the right exit reason'; ok $agg->has_problems, '... and it should report true that there are problems'; # 4. !failed && !todo_passed && !parse_errors && !exit && wait $agg = TAP::Parser::Aggregator->new(); $agg->add( 'tap', $parser5 ); push @{ $agg->{descriptions_for_wait} }, 'another possible reason'; $agg->{wait}++; is $agg->passed, 1, 'coverage tests for !failed && !todo_passed && !parse_errors && !exit... and we should have the correct number of passed tests'; is $agg->failed, 0, '... and we should have the correct number of failed tests'; is $agg->todo_passed, 0, '... and the correct number of unexpectedly succeeded tests'; is $agg->parse_errors, 0, '... and the correct number of parse errors'; is $agg->exit, 0, '... and the correct number of exits'; my @waits = $agg->wait; is @waits, 1, '... and the correct number of waits'; is pop(@waits), 'another possible reason', '... and we collected the right wait reason'; ok $agg->has_problems, '... and it should report true that there are problems'; Test-Harness-3.36/t/lib/0000755000175000017500000000000012640746441013462 5ustar leonleonTest-Harness-3.36/t/lib/EmptyParser.pm0000644000175000017500000000062212426525216016270 0ustar leonleonpackage EmptyParser; use strict; use warnings; use base qw(TAP::Parser); sub _initialize { shift->_set_defaults; } # this should really be in TAP::Parser itself... sub _set_defaults { my $self = shift; for my $key (qw( grammar_class result_factory_class )) { my $default_method = "_default_$key"; $self->$key( $self->$default_method() ); } return $self; } 1; Test-Harness-3.36/t/lib/MyResult.pm0000644000175000017500000000046012426525217015602 0ustar leonleon# subclass for testing customizing & subclassing package MyResult; use strict; use warnings; use base qw( TAP::Parser::Result MyCustom ); sub _initialize { my $self = shift; $self->SUPER::_initialize(@_); $main::INIT{ ref($self) }++; $self->{initialized} = 1; return $self; } 1; Test-Harness-3.36/t/lib/MyIterator.pm0000644000175000017500000000066212426525217016121 0ustar leonleon# subclass for testing customizing & subclassing package MyIterator; use strict; use warnings; use base qw( TAP::Parser::Iterator MyCustom ); sub _initialize { my $self = shift; $self->SUPER::_initialize(@_); $main::INIT{ ref($self) }++; $self->{initialized} = 1; $self->{content} = [ 'whats TAP all about then?', '1..1', 'ok 1' ]; return $self; } sub next { return shift @{ $_[0]->{content} }; } 1; Test-Harness-3.36/t/lib/MyGrammar.pm0000644000175000017500000000046212426525220015706 0ustar leonleon# subclass for testing customizing & subclassing package MyGrammar; use strict; use warnings; use base qw( TAP::Parser::Grammar MyCustom ); sub _initialize { my $self = shift; $self->SUPER::_initialize(@_); $main::INIT{ ref($self) }++; $self->{initialized} = 1; return $self; } 1; Test-Harness-3.36/t/lib/if.pm0000644000175000017500000000227212426525221014412 0ustar leonleonpackage if; $VERSION = '0.05'; sub work { my $method = shift() ? 'import' : 'unimport'; die "Too few arguments to `use if' (some code returning an empty list in list context?)" unless @_ >= 2; return unless shift; # CONDITION my $p = $_[0]; # PACKAGE ( my $file = "$p.pm" ) =~ s!::!/!g; require $file; # Works even if $_[0] is a keyword (like open) my $m = $p->can($method); goto &$m if $m; } sub import { shift; unshift @_, 1; goto &work } sub unimport { shift; unshift @_, 0; goto &work } 1; __END__ =head1 NAME if - C a Perl module if a condition holds =head1 SYNOPSIS use if CONDITION, MODULE => ARGUMENTS; =head1 DESCRIPTION The construct use if CONDITION, MODULE => ARGUMENTS; has no effect unless C is true. In this case the effect is the same as of use MODULE ARGUMENTS; Above C<< => >> provides necessary quoting of C. If not used (e.g., no ARGUMENTS to give), you'd better quote C yourselves. =head1 BUGS The current implementation does not allow specification of the required version of the module. =head1 AUTHOR Ilya Zakharevich L. =cut Test-Harness-3.36/t/lib/App/0000755000175000017500000000000012640746441014202 5ustar leonleonTest-Harness-3.36/t/lib/App/Prove/0000755000175000017500000000000012640746441015275 5ustar leonleonTest-Harness-3.36/t/lib/App/Prove/Plugin/0000755000175000017500000000000012640746441016533 5ustar leonleonTest-Harness-3.36/t/lib/App/Prove/Plugin/Dummy2.pm0000644000175000017500000000024412426525227020245 0ustar leonleonpackage App::Prove::Plugin::Dummy2; use strict; use warnings; sub import { main::test_log_import(@_); } sub load { main::test_log_plugin_load(@_); } 1; Test-Harness-3.36/t/lib/App/Prove/Plugin/Dummy.pm0000644000175000017500000000016112426525230020153 0ustar leonleonpackage App::Prove::Plugin::Dummy; use strict; use warnings; sub import { main::test_log_import(@_); } 1; Test-Harness-3.36/t/lib/NoFork.pm0000644000175000017500000000044212426525231015210 0ustar leonleonpackage NoFork; BEGIN { *CORE::GLOBAL::fork = sub { die "you should not fork" }; } use Config; tied(%Config)->{d_fork} = 0; # blatant lie =begin TEST Assuming not to much chdir: PERL5OPT='-It/lib -MNoFork' perl -Ilib bin/prove -r t =end TEST =cut 1; # vim:ts=4:sw=4:et:sta Test-Harness-3.36/t/lib/MySourceHandler.pm0000644000175000017500000000144612426525232017064 0ustar leonleon# subclass for testing customizing & subclassing package MySourceHandler; use strict; use warnings; use MyIterator; use TAP::Parser::SourceHandler; use TAP::Parser::IteratorFactory; #use base qw( TAP::Parser::SourceHandler MyCustom ); use base 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; Test-Harness-3.36/t/lib/Dev/0000755000175000017500000000000012640746441014200 5ustar leonleonTest-Harness-3.36/t/lib/Dev/Null.pm0000644000175000017500000000051012426525232015437 0ustar leonleon# For shutting up Test::Harness. # Has to work on 5.004 which doesn't have Tie::StdHandle. package Dev::Null; sub WRITE { } sub PRINT { } sub PRINTF { } sub TIEHANDLE { my $class = shift; my $fh = do { local *HANDLE; \*HANDLE }; return bless $fh, $class; } sub READ { } sub READLINE { } sub GETC { } 1; Test-Harness-3.36/t/lib/TAP/0000755000175000017500000000000012640746441014106 5ustar leonleonTest-Harness-3.36/t/lib/TAP/Parser/0000755000175000017500000000000012640746441015342 5ustar leonleonTest-Harness-3.36/t/lib/TAP/Parser/SubclassTest.pm0000644000175000017500000000203512426525233020313 0ustar leonleon# subclass for testing subclassing package TAP::Parser::SubclassTest; use strict; use warnings; use MySourceHandler; use MyPerlSourceHandler; use MyGrammar; use MyResultFactory; use base qw( TAP::Parser MyCustom ); 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; $self->SUPER::_initialize(@_); $main::INIT{ ref($self) }++; $self->{initialized} = 1; return $self; } 1; Test-Harness-3.36/t/lib/TAP/Harness/0000755000175000017500000000000012640746441015511 5ustar leonleonTest-Harness-3.36/t/lib/TAP/Harness/TestSubclass.pm0000644000175000017500000000031212426525234020457 0ustar leonleonpackage TAP::Harness::TestSubclass; use strict; use warnings; use base 'TAP::Harness'; sub aggregate_tests { local $ENV{HARNESS_IS_SUBCLASS} = __PACKAGE__; $_[0]->SUPER::aggregate_tests; } 1; Test-Harness-3.36/t/lib/MyResultFactory.pm0000644000175000017500000000057212426525234017135 0ustar leonleon# subclass for testing customizing & subclassing package MyResultFactory; use strict; use warnings; use MyResult; use base qw( TAP::Parser::ResultFactory MyCustom ); sub make_result { my $class = shift; # I know, this is not really being initialized, but # for consistency's sake, deal with it :) $main::INIT{$class}++; return MyResult->new(@_); } 1; Test-Harness-3.36/t/lib/IO/0000755000175000017500000000000012640746441013771 5ustar leonleonTest-Harness-3.36/t/lib/IO/c55Capture.pm0000644000175000017500000000441212426525235016246 0ustar leonleonpackage IO::c55Capture; use IO::Handle; =head1 Name t/lib/IO::c55Capture - a wafer-thin test support package =head1 Why!? Compatibility with 5.5.3 and no external dependencies. =head1 Usage Works with a global filehandle: # set a spool to write to tie local *STDOUT, 'IO::c55Capture'; ... # clear and retrieve buffer list my @spooled = tied(*STDOUT)->dump(); Or, a lexical (and autocreated) filehandle: my $capture = IO::c55Capture->new_handle; ... my @output = tied($$capture)->dump; Note the '$$' dereference. =cut # XXX actually returns an IO::Handle :-/ sub new_handle { my $class = shift; my $handle = IO::Handle->new; tie $$handle, $class; return ($handle); } sub TIEHANDLE { return bless [], __PACKAGE__; } sub PRINT { my $self = shift; push @$self, @_; } sub PRINTF { my $self = shift; push @$self, sprintf(@_); } sub dump { my $self = shift; my @got = @$self; @$self = (); return @got; } package util; use IO::File; # mostly stolen from Module::Build MBTest.pm { # backwards compatible temp filename recipe adapted from perlfaq my $tmp_count = 0; my $tmp_base_name = sprintf( "%d-%d", $$, time() ); sub temp_file_name { sprintf( "%s-%04d", $tmp_base_name, ++$tmp_count ); } } ######################################################################## sub save_handle { my ( $handle, $subr ) = @_; my $outfile = temp_file_name(); local *SAVEOUT; open SAVEOUT, ">&" . fileno($handle) or die "Can't save output handle: $!"; open $handle, "> $outfile" or die "Can't create $outfile: $!"; eval { $subr->() }; my $err = $@; open $handle, ">&SAVEOUT" or die "Can't restore output: $!"; my $ret = slurp($outfile); 1 while unlink $outfile; $err and die $err; return $ret; } sub stdout_of { save_handle( \*STDOUT, @_ ) } sub stderr_of { save_handle( \*STDERR, @_ ) } sub stdout_stderr_of { my $subr = shift; my ( $stdout, $stderr ); $stdout = stdout_of( sub { $stderr = stderr_of($subr); } ); return ( $stdout, $stderr ); } sub slurp { my $fh = IO::File->new( $_[0] ) or die "Can't open $_[0]: $!"; local $/; return scalar <$fh>; } 1; # vim:ts=4:sw=4:et:sta Test-Harness-3.36/t/lib/MyFileSourceHandler.pm0000644000175000017500000000127612426525633017672 0ustar leonleon# subclass for testing TAP::Harness custom sources package MyFileSourceHandler; use strict; use warnings; our ($LAST_OBJ, $CAN_HANDLE, $MAKE_ITER, $LAST_SOURCE); use TAP::Parser::IteratorFactory; use base 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; Test-Harness-3.36/t/lib/NOP.pm0000644000175000017500000000010112426525237014444 0ustar leonleonpackage NOP; # Do nothing much sub new { bless {}, shift } 1; Test-Harness-3.36/t/lib/MyCustom.pm0000644000175000017500000000030412426525237015575 0ustar leonleon# avoid cut-n-paste exhaustion with this mixin package MyCustom; use strict; use warnings; sub custom { my $self = shift; $main::CUSTOM{ ref($self) || $self }++; return $self; } 1; Test-Harness-3.36/t/lib/MyPerlSourceHandler.pm0000644000175000017500000000067112426525240017705 0ustar leonleon# subclass for testing customizing & subclassing package MyPerlSourceHandler; use strict; use warnings; use TAP::Parser::IteratorFactory; use base 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; Test-Harness-3.36/t/nofork-mux.t0000644000175000017500000000016712426525263015211 0ustar leonleon#!/usr/bin/perl -w BEGIN { use lib 't/lib'; } use strict; use warnings; use NoFork; require('t/multiplexer.t'); Test-Harness-3.36/t/source_handler.t0000644000175000017500000003050512426525633016101 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More tests => 79; use Config; use IO::File; use IO::Handle; use File::Spec; 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( 't', 'source_tests' ); my $perl = $^X; my %file = map { $_ => File::Spec->catfile( $dir, $_ ) } qw( source source.1 source.bat source.pl source.sh source_args.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, }, { 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.25, }, { name => 'exec hash', raw => { exec => 'foo' }, meta => { is_hash => 1 }, vote => 0.9, }, ], make_iterator => [ { name => "valid executable", raw => [ $perl, ( $ENV{PERL_CORE} ? '-I../../lib' : () ), (map { "-I$_" } split /$Config{path_sep}/, $ENV{PERL5LIB} || ''), '-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_args.sh'}, raw => { exec => [ $file{'source_args.sh'} ] }, test_args => ['foo'], 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_args.sh foo' ], 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 ); } ############################################################################### # 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->test_args( $test->{test_args} ) if $test->{test_args}; $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'; } } } } Test-Harness-3.36/t/streams.t0000755000175000017500000001452612426525266014574 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 49; use TAP::Parser; use TAP::Parser::Iterator::Array; use TAP::Parser::Iterator::Stream; my $ITER = 'TAP::Parser::Iterator'; my $ITER_FH = "${ITER}::Stream"; my $ITER_ARRAY = "${ITER}::Array"; 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, '_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'; is $parser->next->as_string, 'ok 1 - input file opened', '... and the first test should parse correctly'; is $parser->next->as_string, '... this is junk', '... and junk should parse correctly'; is $parser->next->as_string, 'not ok 2 first line of the input valid # TODO some data', '... and the second test should parse correctly'; is $parser->next->as_string, '# this is a comment', '... and comments should parse correctly'; is $parser->next->as_string, 'ok 3 - read the rest of the file', '... and the third test should parse correctly'; is $parser->next->as_string, 'not ok 4 - this is a real failure', '... and the fourth test should parse correctly'; is $parser->next->as_string, 'ok 5 # SKIP we have no description', '... and fifth test should parse correctly'; ok !$parser->parse_errors, '... and we should have no parse errors'; # plan at end my $tap = <<'END_TAP'; ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure ok 5 # skip we have no description 1..5 END_TAP $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->_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'; is $parser->next->as_string, '... this is junk', '... and junk should parse correctly'; is $parser->next->as_string, 'not ok 2 first line of the input valid # TODO some data', '... and the second test should parse correctly'; is $parser->next->as_string, '# this is a comment', '... and comments should parse correctly'; is $parser->next->as_string, 'ok 3 - read the rest of the file', '... and the third test should parse correctly'; is $parser->next->as_string, 'not ok 4 - this is a real failure', '... and the fourth test should parse correctly'; is $parser->next->as_string, 'ok 5 # SKIP we have no description', '... and fifth test should parse correctly'; is $parser->next->as_string, '1..5', '... and the plan should parse correctly'; ok !$parser->parse_errors, '... and we should have no parse errors'; # misplaced plan (and one-off errors) $tap = <<'END_TAP'; ok 1 - input file opened 1..5 ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure ok 5 # skip we have no description END_TAP $iterator = $ITER_ARRAY->new( [ split /\n/ => $tap ] ); 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'; is $parser->next->as_string, '1..5', '... and the plan should parse correctly'; is $parser->next->as_string, '... this is junk', '... and junk should parse correctly'; is $parser->next->as_string, 'not ok 2 first line of the input valid # TODO some data', '... and the second test should parse correctly'; is $parser->next->as_string, '# this is a comment', '... and comments should parse correctly'; is $parser->next->as_string, 'ok 3 - read the rest of the file', '... and the third test should parse correctly'; is $parser->next->as_string, 'not ok 4 - this is a real failure', '... and the fourth test should parse correctly'; is $parser->next->as_string, 'ok 5 # SKIP we have no description', '... and fifth test should parse correctly'; ok $parser->parse_errors, '... and we should have one parse error'; is + ( $parser->parse_errors )[0], 'Plan (1..5) must be at the beginning or end of the TAP output', '... telling us that our plan went awry'; $tap = <<'END_TAP'; ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure 1..5 ok 5 # skip we have no description END_TAP $iterator = $ITER_ARRAY->new( [ split /\n/ => $tap ] ); 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'; is $parser->next->as_string, '... this is junk', '... and junk should parse correctly'; is $parser->next->as_string, 'not ok 2 first line of the input valid # TODO some data', '... and the second test should parse correctly'; is $parser->next->as_string, '# this is a comment', '... and comments should parse correctly'; is $parser->next->as_string, 'ok 3 - read the rest of the file', '... and the third test should parse correctly'; is $parser->next->as_string, 'not ok 4 - this is a real failure', '... and the fourth test should parse correctly'; is $parser->next->as_string, '1..5', '... and the plan should parse correctly'; is $parser->next->as_string, 'ok 5 # SKIP we have no description', '... and fifth test should parse correctly'; ok $parser->parse_errors, '... and we should have one parse error'; is + ( $parser->parse_errors )[0], 'Plan (1..5) must be at the beginning or end of the TAP output', '... telling us that our plan went awry'; __DATA__ 1..5 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure ok 5 # skip we have no description Test-Harness-3.36/t/iterator_factory.t0000644000175000017500000001146212426525267016470 0ustar leonleon#!/usr/bin/perl -w # # Tests for TAP::Parser::IteratorFactory & source detection ## BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; 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( '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::Perl', 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 Test-Harness-3.36/t/proveversion.t0000644000175000017500000000147312536251412015640 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } sub _has_TAP_Formatter_HTML { eval "use TAP::Formatter::HTML 0.10"; #https://rt.cpan.org/Ticket/Display.html?id=74364 return $@ ? 0 : 1; } use strict; use warnings; use Test::More tests => 1; use IO::c55Capture; # for util SKIP: { skip "requires TAP::Formatter::HTML 0.10", 1 unless _has_TAP_Formatter_HTML(); my $ans = util::stdout_of( sub { system( $^X, "bin/prove", "-l", "--formatter=TAP::Formatter::HTML", "--tapversion=13", "t/sample-tests/simple_yaml_missing_version13" ) and die "error $?"; } ); like( $ans, qr/li class="yml"/, "prove --tapversion=13 simple_yaml_missing_version13" ); } Test-Harness-3.36/t/yamlish-writer.t0000644000175000017500000001625512426525271016070 0ustar leonleon#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Test::More; use TAP::Parser::YAMLish::Reader; use TAP::Parser::YAMLish::Writer; my @SCHEDULE; BEGIN { @SCHEDULE = ( { name => 'Simple scalar', in => 1, out => [ '--- 1', '...', ], }, { name => 'Undef', in => undef, out => [ '--- ~', '...', ], }, { name => 'Unprintable', in => "\x01\n\t", out => [ '--- "\x01\n\t"', '...', ], }, { name => 'Simple array', in => [ 1, 2, 3 ], out => [ '---', '- 1', '- 2', '- 3', '...', ], }, { name => 'Empty array', in => [], out => [ '--- []', '...' ], }, { name => 'Empty hash', in => {}, out => [ '--- {}', '...' ], }, { name => 'Array, two elements, undef', in => [ undef, undef ], out => [ '---', '- ~', '- ~', '...', ], }, { name => 'Nested array', in => [ 1, 2, [ 3, 4 ], 5 ], out => [ '---', '- 1', '- 2', '-', ' - 3', ' - 4', '- 5', '...', ], }, { name => 'Nested empty', in => [ 1, 2, [], 5 ], out => [ '---', '- 1', '- 2', '- []', '- 5', '...', ], }, { name => 'Simple hash', in => { one => '1', two => '2', three => '3' }, out => [ '---', 'one: 1', 'three: 3', 'two: 2', '...', ], }, { name => 'Nested hash', in => { one => '1', two => '2', more => { three => '3', four => '4' } }, out => [ '---', 'more:', ' four: 4', ' three: 3', 'one: 1', 'two: 2', '...', ], }, { name => 'Nested empty', in => { one => '1', two => '2', more => {} }, out => [ '---', 'more: {}', 'one: 1', 'two: 2', '...', ], }, { name => 'Unprintable key', in => { one => '1', "\x02" => '2', three => '3' }, out => [ '---', '"\x02": 2', 'one: 1', 'three: 3', '...', ], }, { name => 'Empty key', in => { '' => 'empty' }, out => [ '---', "'': empty", '...', ], }, { name => 'Empty value', in => { '' => '' }, out => [ '---', "'': ''", '...', ], }, { name => 'Funky hash key', in => { './frob' => 'is_frob' }, out => [ '---', '"./frob": is_frob', '...', ] }, { name => 'Complex', in => { 'bill-to' => { 'given' => 'Chris', 'address' => { 'city' => 'Royal Oak', 'postal' => '48046', 'lines' => "458 Walkman Dr.\nSuite #292\n", 'state' => 'MI' }, 'family' => 'Dumars' }, 'invoice' => '34843', 'date' => '2001-01-23', 'tax' => '251.42', 'product' => [ { 'sku' => 'BL394D', 'quantity' => '4', 'price' => '450.00', 'description' => 'Basketball' }, { 'sku' => 'BL4438H', 'quantity' => '1', 'price' => '2392.00', 'description' => 'Super Hoop' } ], 'comments' => "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", 'total' => '4443.52' }, out => [ "---", "bill-to:", " address:", " city: \"Royal Oak\"", " lines: \"458 Walkman Dr.\\nSuite #292\\n\"", " postal: 48046", " state: MI", " family: Dumars", " given: Chris", "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"", "date: 2001-01-23", "invoice: 34843", "product:", " -", " description: Basketball", " price: 450.00", " quantity: 4", " sku: BL394D", " -", " description: \"Super Hoop\"", " price: 2392.00", " quantity: 1", " sku: BL4438H", "tax: 251.42", "total: 4443.52", "...", ], }, ); plan tests => @SCHEDULE * 6; } sub iter { my $ar = shift; return sub { return shift @$ar; }; } for my $test (@SCHEDULE) { my $name = $test->{name}; ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created"; isa_ok $yaml, 'TAP::Parser::YAMLish::Writer'; my $got = []; my $writer = sub { push @$got, shift }; my $data = $test->{in}; eval { $yaml->write( $data, $writer ) }; if ( my $err = $test->{error} ) { unless ( like $@, $err, "$name: Error message" ) { diag "Error: $@\n"; } is_deeply $got, [], "$name: No result"; pass; } else { my $want = $test->{out}; unless ( ok !$@, "$name: No error" ) { diag "Error: $@\n"; } unless ( is_deeply $got, $want, "$name: Result matches" ) { use Data::Dumper; diag Dumper($got); diag Dumper($want); } my $yr = TAP::Parser::YAMLish::Reader->new; # Now try parsing it my $reader = sub { shift @$got }; my $parsed = eval { $yr->read($reader) }; ok !$@, "$name: no error" or diag "$@"; is_deeply $parsed, $data, "$name: Reparse OK"; } } Test-Harness-3.36/t/taint.t0000644000175000017500000000246612426525633014230 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } # Test that environment options are propagated to tainted tests use strict; use warnings; use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 2 ) ); use Config; use TAP::Parser; my $lib_path = join( ', ', map "'$_'", grep !ref, grep defined, @INC ); sub run_test_file { my ( $test_template, @args ) = @_; my $test_file = 'temp_test.tmp'; open TEST, ">$test_file" or die $!; printf TEST $test_template, @args; close TEST; my $p = TAP::Parser->new( { source => $test_file, # Test taint when there's spaces in a -I path switches => [q["-Ifoo bar"]], } ); 1 while $p->next; ok !$p->has_problems; unlink $test_file; } { local $ENV{PERL5OPT} = $ENV{PERL_CORE} ? '-I../../lib -Mstrict' : '-Mstrict'; run_test_file(<<'END'); #!/usr/bin/perl -T print "1..1\n"; print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n"; END } # Check that PERL5LIB is propagated to -T. { my $sentinel_dir = 'i/do/not/exist'; local $ENV{PERL5LIB} = join $Config{path_sep}, $ENV{PERL5LIB} || '', $sentinel_dir; run_test_file(sprintf <<'END', $sentinel_dir); #!/usr/bin/perl -T print "1..1\n"; my $ok = grep { $_ eq '%s' } @INC; print $ok ? "ok 1\n" : "not ok 1\n"; END } 1; Test-Harness-3.36/t/object.t0000644000175000017500000000140412426525272014345 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 7; use_ok('TAP::Object'); can_ok( 'TAP::Object', 'new' ); can_ok( 'TAP::Object', '_initialize' ); can_ok( 'TAP::Object', '_croak' ); { package TAP::TestObj; use base qw(TAP::Object); sub _initialize { my $self = shift; $self->{init} = 1; $self->{args} = [@_]; return $self; } } # I know these tests are simple, but they're documenting the base API, so # necessary none-the-less... my $obj = TAP::TestObj->new( 'foo', { bar => 'baz' } ); ok( $obj->{init}, '_initialize' ); is_deeply( $obj->{args}, [ 'foo', { bar => 'baz' } ], '_initialize: args' ); eval { $obj->_croak('eek') }; my $err = $@; like( $err, qr/^eek/, '_croak' ); Test-Harness-3.36/t/perl5lib.t0000644000175000017500000000220212426525633014613 0ustar leonleon#!/usr/bin/perl -w # Test that PERL5LIB is propogated from the harness process to the test # process. use strict; use warnings; use lib 't/lib'; use Config; my $path_sep = $Config{path_sep}; sub has_crazy_patch { my $sentinel = 'blirpzoffle'; local $ENV{PERL5LIB} = $sentinel; my $command = join ' ', map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' ); my $path = `$command`; my @got = ( $path =~ /($sentinel)/g ); return @got > 1; } use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' ) : ( tests => 1 ) ); use Test::Harness; use App::Prove; # Change PERL5LIB so we ensure it's preserved. $ENV{PERL5LIB} = join( $path_sep, 'wibble', $ENV{PERL5LIB} || '' ); open TEST, ">perl5lib_check.t.tmp"; print TEST <<"END"; #!/usr/bin/perl use strict; use Test::More tests => 1; like \$ENV{PERL5LIB}, qr/(^|${path_sep})wibble${path_sep}/; END close TEST; END { 1 while unlink 'perl5lib_check.t.tmp'; } my $h = TAP::Harness->new( { lib => ['something'], verbosity => -3 } ); ok( !$h->runtests('perl5lib_check.t.tmp')->has_errors ); 1; Test-Harness-3.36/t/testargs.t0000644000175000017500000001171012426525274014736 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More; use File::Spec; use TAP::Parser; use TAP::Harness; use App::Prove; diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV; my @cleanup = (); END { unlink @cleanup } my $test = File::Spec->catfile( 't', 'sample-tests', 'echo' ); my @test = ( [ perl => $test ], make_shell_test($test) ); plan tests => @test * 8 + 5; sub echo_ok { my ( $type, $options ) = ( shift, shift ); my $name = join( ', ', sort keys %$options ) . ", $type"; my @args = @_; my $parser = TAP::Parser->new( { %$options, test_args => \@args } ); my @got = (); while ( my $result = $parser->next ) { push @got, $result; } my $plan = shift @got; ok $plan->is_plan, "$name: is_plan"; is_deeply [ map { $_->description } @got ], [@args], "$name: option passed OK"; } for my $t (@test) { my ( $type, $test ) = @$t; for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) { echo_ok( $type, { source => $test }, @$args ); echo_ok( $type, { exec => [ $^X, $test ] }, @$args ); } } sub make_shell_test { my $test = shift; my $shell = '/bin/sh'; return unless -x $shell; my $script = "shell_$$.sh"; push @cleanup, $script; { open my $sh, '>', $script; print $sh "#!$shell\n\n"; print $sh "$^X '$test' \$*\n"; } chmod 0775, $script; return unless -x $script; return [ shell => $script ]; } { 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; use base 'App::Prove'; sub _runtests { my $self = shift; push @{ $self->{_log} }, [@_]; return; } sub get_run_log { my $self = shift; return $self->{_log}; } package main; { my $app = Test::Prove->new; $app->process_args( '--norc', $test, '::', 'one', 'two', 'huh' ); $app->run(); my $log = $app->get_run_log; is_deeply $log->[0]->[0]->{test_args}, [ 'one', 'two', 'huh' ], "prove args match"; } sub bigness { my $str = join '', @_; my @cdef = ( '0000000000000000', '1818181818001800', '6c6c6c0000000000', '36367f367f363600', '0c3f683e0b7e1800', '60660c1830660600', '386c6c386d663b00', '0c18300000000000', '0c18303030180c00', '30180c0c0c183000', '00187e3c7e180000', '0018187e18180000', '0000000000181830', '0000007e00000000', '0000000000181800', '00060c1830600000', '3c666e7e76663c00', '1838181818187e00', '3c66060c18307e00', '3c66061c06663c00', '0c1c3c6c7e0c0c00', '7e607c0606663c00', '1c30607c66663c00', '7e060c1830303000', '3c66663c66663c00', '3c66663e060c3800', '0000181800181800', '0000181800181830', '0c18306030180c00', '00007e007e000000', '30180c060c183000', '3c660c1818001800', '3c666e6a6e603c00', '3c66667e66666600', '7c66667c66667c00', '3c66606060663c00', '786c6666666c7800', '7e60607c60607e00', '7e60607c60606000', '3c66606e66663c00', '6666667e66666600', '7e18181818187e00', '3e0c0c0c0c6c3800', '666c7870786c6600', '6060606060607e00', '63777f6b6b636300', '6666767e6e666600', '3c66666666663c00', '7c66667c60606000', '3c6666666a6c3600', '7c66667c6c666600', '3c66603c06663c00', '7e18181818181800', '6666666666663c00', '66666666663c1800', '63636b6b7f776300', '66663c183c666600', '6666663c18181800', '7e060c1830607e00', '7c60606060607c00', '006030180c060000', '3e06060606063e00', '183c664200000000', '00000000000000ff', '1c36307c30307e00', '00003c063e663e00', '60607c6666667c00', '00003c6660663c00', '06063e6666663e00', '00003c667e603c00', '1c30307c30303000', '00003e66663e063c', '60607c6666666600', '1800381818183c00', '1800381818181870', '6060666c786c6600', '3818181818183c00', '0000367f6b6b6300', '00007c6666666600', '00003c6666663c00', '00007c66667c6060', '00003e66663e0607', '00006c7660606000', '00003e603c067c00', '30307c3030301c00', '0000666666663e00', '00006666663c1800', '0000636b6b7f3600', '0000663c183c6600', '00006666663e063c', '00007e0c18307e00', '0c18187018180c00', '1818180018181800', '3018180e18183000', '316b460000000000' ); my @chars = unpack( 'C*', $str ); my @out = (); for my $row ( 0 .. 7 ) { for my $char (@chars) { next if $char < 32 || $char > 126; my $size = scalar(@cdef); my $byte = hex( substr( $cdef[ $char - 32 ], $row * 2, 2 ) ); my $bits = sprintf( '%08b', $byte ); $bits =~ tr/01/ #/; push @out, $bits; } push @out, "\n"; } return join '', @out; } Test-Harness-3.36/t/proverun.t0000644000175000017500000001021512426525633014760 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More; use File::Spec; use App::Prove; use Text::ParseWords qw(shellwords); my @SCHEDULE; BEGIN { my $t_dir = File::Spec->catdir('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 # automatically. my @tests = ( { file => 'simple', name => 'Create empty', }, { file => 'todo_inline', name => 'Passing TODO', }, ); # 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_dir, 'sample-tests', $test->{file} ); } @SCHEDULE = ( map { { name => $_->{name}, args => [ $_->{file} ], expect => [ [ 'new', 'TAP::Parser::Iterator::Process', { merge => undef, command => [ 'PERL', $ENV{HARNESS_PERL_SWITCHES} ? shellwords( $ENV{HARNESS_PERL_SWITCHES} ) : (), $_->{file}, ], setup => \'CODE', teardown => \'CODE', } ] ] } } @tests, ); plan tests => @SCHEDULE * 3; } # Waaaaay too much boilerplate package FakeProve; use base qw( App::Prove ); sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->{_log} = []; return $self; } sub get_log { my $self = shift; my @log = @{ $self->{_log} }; $self->{_log} = []; return @log; } package main; { use TAP::Parser::Iterator::Process; use TAP::Formatter::Console; # Patch TAP::Parser::Iterator::Process my @call_log = (); no warnings qw(redefine once); my $orig_new = TAP::Parser::Iterator::Process->can('new'); *TAP::Parser::Iterator::Process::new = sub { push @call_log, [ 'new', @_ ]; # And then new turns round and tramples on our args... $_[1] = { %{ $_[1] } }; $orig_new->(@_); }; # Patch TAP::Formatter::Console; my $orig_output = \&TAP::Formatter::Console::_output; *TAP::Formatter::Console::_output = sub { # push @call_log, [ '_output', @_ ]; }; sub get_log { my @log = @call_log; @call_log = (); return @log; } } sub _slacken { my $obj = shift; if ( my $ref = ref $obj ) { if ( 'HASH' eq ref $obj ) { return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj }; } elsif ( 'ARRAY' eq ref $obj ) { return [ map { _slacken($_) } @$obj ]; } elsif ( 'SCALAR' eq ref $obj ) { return $obj; } else { return \$ref; } } else { return $obj; } } sub is_slackly($$$) { my ( $got, $want, $msg ) = @_; return is_deeply _slacken($got), _slacken($want), $msg; } # ACTUAL TEST for my $test (@SCHEDULE) { my $name = $test->{name}; my $app = FakeProve->new; $app->process_args( '--norc', @{ $test->{args} } ); # Why does this make the output from the test spew out of # our STDOUT? ok eval { $app->run }, 'run returned true'; ok !$@, 'no errors' or diag $@; my @log = get_log(); # Bodge: we don't know what pathname will be used for the exe so we # obliterate it here. Need to test that it's sane. for my $call (@log) { if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) { $call->[2]->{command}->[0] = 'PERL'; } } is_slackly \@log, $test->{expect}, "$name: command args OK"; # use Data::Dumper; # diag Dumper( # { got => \@log, # expect => $test->{expect} # } # ); } Test-Harness-3.36/t/000-load.t0000644000175000017500000000403312426525276014320 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; 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; } 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; } Test-Harness-3.36/t/multiplexer.t0000644000175000017500000001104112426525633015450 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More qw( no_plan ); use File::Spec; use TAP::Parser; use TAP::Parser::Multiplexer; use TAP::Parser::Iterator::Process; my $fork_desc = TAP::Parser::Iterator::Process->_use_open3 ? 'fork' : 'nofork'; my @schedule = ( { name => 'Single non-selectable source', # Returns a list of parser, stash pairs. The stash contains the # TAP that we expect from this parser. sources => sub { my @tap = ( '1..1', 'ok 1 Just fine' ); return [ TAP::Parser->new( { tap => join( "\n", @tap ) . "\n" } ), \@tap, ]; }, }, { name => 'Two non-selectable sources', sources => sub { my @tap = ( [ '1..1', 'ok 1 Just fine' ], [ '1..2', 'not ok 1 Oh dear', 'ok 2 Better' ] ); return map { [ TAP::Parser->new( { tap => join( "\n", @$_ ) . "\n" } ), $_ ] } @tap; }, }, { name => 'Single selectable source', sources => sub { return [ TAP::Parser->new( { source => File::Spec->catfile( 't', 'sample-tests', 'simple' ), } ), [ '1..5', 'ok 1', 'ok 2', 'ok 3', 'ok 4', 'ok 5', ] ]; }, }, { name => 'Three selectable sources', sources => sub { return map { [ TAP::Parser->new( { source => File::Spec->catfile( 't', 'sample-tests', 'simple' ), } ), [ '1..5', 'ok 1', 'ok 2', 'ok 3', 'ok 4', 'ok 5', ] ] } 1 .. 3; }, }, { name => 'Three selectable sources, two non-selectable sources', sources => sub { my @tap = ( [ '1..1', 'ok 1 Just fine' ], [ '1..2', 'not ok 1 Oh dear', 'ok 2 Better' ] ); return ( map { [ TAP::Parser->new( { tap => join( "\n", @$_ ) . "\n" } ), $_ ] } @tap ), ( map { [ TAP::Parser->new( { source => File::Spec->catfile( 't', 'sample-tests', 'simple' ), } ), [ '1..5', 'ok 1', 'ok 2', 'ok 3', 'ok 4', 'ok 5', ] ] } 1 .. 3 ); }, } ); for my $test (@schedule) { my $name = "$test->{name} ($fork_desc)"; my @sources = $test->{sources}->(); my $mux = TAP::Parser::Multiplexer->new; my $count = @sources; $mux->add(@$_) for @sources; is $mux->parsers, $count, "$name: count OK"; while ( my ( $parser, $stash, $result ) = $mux->next ) { # use Data::Dumper; # diag Dumper( { stash => $stash, result => $result } ); if ( defined $result ) { my $expect = ( shift @$stash ) || ' OOPS '; my $got = $result->raw; is $got, $expect, "$name: '$expect' OK"; } else { ok @$stash == 0, "$name: EOF OK"; # Make sure we only get one EOF per stream push @$stash, ' expect no more '; } } is $mux->parsers, 0, "$name: All used up"; } 1; Test-Harness-3.36/t/parser-subclass.t0000644000175000017500000000431712426525633016217 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; our (%INIT, %CUSTOM); use Test::More tests => 14; use File::Spec::Functions qw( catfile updir ); use_ok('TAP::Parser::SubclassTest'); # TODO: for my $source ( ... ) ? my @t_path = (); { # perl source %INIT = %CUSTOM = (); 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 # trigger it's creation. my $grammer = $p->_grammar; ok( $p->{initialized}, 'new subclassed parser' ); is( $p->grammar_class => 'MyGrammar', 'grammar_class' ); is( $p->result_factory_class => 'MyResultFactory', 'result_factory_class' ); is( $INIT{MyGrammar}, 1, 'initialized MyGrammar' ); is( $CUSTOM{MyGrammar}, 1, '... and it was customized' ); # make sure overrided make_* methods work... %CUSTOM = (); $p->make_grammar; is( $CUSTOM{MyGrammar}, 1, 'make custom grammar' ); $p->make_result; is( $CUSTOM{MyResult}, 1, 'make custom result' ); # make sure parser helpers use overrided classes too (the parser should # be the central source of configuration/overriding functionality) # The source is already tested above (parser doesn't keep a copy of the # source currently). So only one to check is the Grammar: %INIT = %CUSTOM = (); my $r = $p->_grammar->tokenize; isa_ok( $r, 'MyResult', 'i has results' ); is( $INIT{MyResult}, 1, 'initialized MyResult' ); is( $CUSTOM{MyResult}, 1, '... and it was customized' ); is( $INIT{MyResultFactory}, 1, '"initialized" MyResultFactory' ); } SKIP: { # non-perl source %INIT = %CUSTOM = (); my $cat = '/bin/cat'; unless ( -e $cat ) { skip "no '$cat'", 2; } my $file = catfile( @t_path, 't', 'data', 'catme.1' ); my $p = TAP::Parser::SubclassTest->new( { exec => [ $cat => $file ], sources => { MySourceHandler => { accept_all => 1 } }, } ); is( $CUSTOM{MySourceHandler}, 1, 'customized a MySourceHandler' ); is( $INIT{MyIterator}, 1, 'initialized MyIterator subclass' ); } Test-Harness-3.36/t/scheduler.t0000644000175000017500000001252312426525302015053 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More; use TAP::Parser::Scheduler; my $perl_rules = { par => [ { seq => '../ext/DB_File/t/*' }, { seq => '../ext/IO_Compress_Zlib/t/*' }, { seq => '../lib/CPANPLUS/*' }, { seq => '../lib/ExtUtils/t/*' }, '*' ] }; my $incomplete_rules = { par => [ { seq => [ '*A', '*D' ] } ] }; my $some_tests = [ '../ext/DB_File/t/A', 'foo', '../ext/DB_File/t/B', '../ext/DB_File/t/C', '../lib/CPANPLUS/D', '../lib/CPANPLUS/E', 'bar', '../lib/CPANPLUS/F', '../ext/DB_File/t/D', '../ext/DB_File/t/E', '../ext/DB_File/t/F', ]; my @schedule = ( { name => 'Sequential, no rules', tests => $some_tests, jobs => 1, }, { name => 'Sequential, Perl rules', rules => $perl_rules, tests => $some_tests, jobs => 1, }, { name => 'Two in parallel, Perl rules', rules => $perl_rules, tests => $some_tests, jobs => 2, }, { name => 'Massively parallel, Perl rules', rules => $perl_rules, tests => $some_tests, jobs => 1000, }, { name => 'Massively parallel, no rules', tests => $some_tests, jobs => 1000, }, { name => 'Sequential, incomplete rules', rules => $incomplete_rules, tests => $some_tests, jobs => 1, }, { name => 'Two in parallel, incomplete rules', rules => $incomplete_rules, tests => $some_tests, jobs => 2, }, { name => 'Massively parallel, incomplete rules', rules => $incomplete_rules, tests => $some_tests, jobs => 1000, }, ); plan tests => @schedule * 2 + 266; for my $test (@schedule) { test_scheduler( $test->{name}, $test->{tests}, $test->{rules}, $test->{jobs} ); } # An ad-hoc test { my @tests = qw( A1 A2 A3 B1 C1 C8 C5 C7 C4 C6 C3 C2 C9 D1 D2 D3 E3 E2 E1 ); my $rules = { par => [ { seq => 'A*' }, { par => 'B*' }, { seq => [ 'C1', 'C2' ] }, { par => [ { seq => [ 'C3', 'C4', 'C5' ] }, { seq => [ 'C6', 'C7', 'C8' ] } ] }, { seq => [ { par => ['D*'] }, { par => ['E*'] } ] }, ] }; my $scheduler = TAP::Parser::Scheduler->new( tests => \@tests, rules => $rules ); # diag $scheduler->as_string; my $A1 = ok_job( $scheduler, 'A1' ); my $B1 = ok_job( $scheduler, 'B1' ); finish($A1); my $A2 = ok_job( $scheduler, 'A2' ); my $C1 = ok_job( $scheduler, 'C1' ); finish( $A2, $C1 ); my $A3 = ok_job( $scheduler, 'A3' ); my $C2 = ok_job( $scheduler, 'C2' ); finish( $A3, $C2 ); my $C3 = ok_job( $scheduler, 'C3' ); my $C6 = ok_job( $scheduler, 'C6' ); my $D1 = ok_job( $scheduler, 'D1' ); my $D2 = ok_job( $scheduler, 'D2' ); finish($C6); my $C7 = ok_job( $scheduler, 'C7' ); my $D3 = ok_job( $scheduler, 'D3' ); ok_job( $scheduler, '#' ); ok_job( $scheduler, '#' ); finish( $D3, $C3, $D1, $B1 ); my $C4 = ok_job( $scheduler, 'C4' ); finish( $C4, $C7 ); my $C5 = ok_job( $scheduler, 'C5' ); my $C8 = ok_job( $scheduler, 'C8' ); ok_job( $scheduler, '#' ); finish($D2); my $E3 = ok_job( $scheduler, 'E3' ); my $E2 = ok_job( $scheduler, 'E2' ); my $E1 = ok_job( $scheduler, 'E1' ); finish( $E1, $E2, $E3, $C5, $C8 ); my $C9 = ok_job( $scheduler, 'C9' ); ok_job( $scheduler, undef ); } { my @tests = (); for my $t ( 'A' .. 'Z' ) { push @tests, map {"$t$_"} 1 .. 9; } my $rules = { par => [ map { { seq => "$_*" } } 'A' .. 'Z' ] }; my $scheduler = TAP::Parser::Scheduler->new( tests => \@tests, rules => $rules ); # diag $scheduler->as_string; for my $n ( 1 .. 9 ) { my @got = (); push @got, ok_job( $scheduler, "$_$n" ) for 'A' .. 'Z'; ok_job( $scheduler, $n == 9 ? undef : '#' ); finish(@got); } } sub finish { $_->finish for @_ } sub ok_job { my ( $scheduler, $want ) = @_; my $job = $scheduler->get_job; if ( !defined $want ) { ok !defined $job, 'undef'; } elsif ( $want eq '#' ) { ok $job->is_spinner, 'spinner'; } else { is $job->filename, $want, $want; } return $job; } sub test_scheduler { my ( $name, $tests, $rules, $jobs ) = @_; ok my $scheduler = TAP::Parser::Scheduler->new( tests => $tests, defined $rules ? ( rules => $rules ) : (), ), "$name: new"; # diag $scheduler->as_string; my @pipeline = (); my @got = (); while ( defined( my $job = $scheduler->get_job ) ) { # diag $scheduler->as_string; if ( $job->is_spinner || @pipeline >= $jobs ) { die "Oops! Spinner!" unless @pipeline; my $done = shift @pipeline; $done->finish; # diag "Completed ", $done->filename; } next if $job->is_spinner; # diag " Got ", $job->filename; push @pipeline, $job; push @got, $job->filename; } is_deeply [ sort @got ], [ sort @$tests ], "$name: got all tests"; } Test-Harness-3.36/t/regression.t0000644000175000017500000033717212426525633015276 0ustar leonleon#!/usr/bin/perl -w BEGIN { push @INC, 't/lib'; } use strict; use warnings; use Test::More 'no_plan'; use File::Spec; use Config; use constant TRUE => "__TRUE__"; use constant FALSE => "__FALSE__"; # if wait() is non-zero, we cannot reliably predict its value use constant NOT_ZERO => "__NOT_ZERO__"; use TAP::Parser; my $IsVMS = $^O eq 'VMS'; my $IsWin32 = $^O eq 'MSWin32'; my $SAMPLE_TESTS = File::Spec->catdir( File::Spec->curdir, 't', 'sample-tests' ); my %deprecated = map { $_ => 1 } qw( TAP::Parser::good_plan TAP::Parser::Result::Plan::passed TAP::Parser::Result::Test::passed TAP::Parser::Result::Test::actual_passed TAP::Parser::Result::passed ); $SIG{__WARN__} = sub { if ( $_[0] =~ /is deprecated/ ) { my @caller = caller(1); my $sub = $caller[3]; ok exists $deprecated{$sub}, "... we should get a deprecated warning for $sub"; } else { CORE::warn @_; } }; # the %samples keys are the names of test scripts in t/sample-tests my %samples = ( descriptive => { results => [ { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => "Interlock activated", passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "Megathrusters are go", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "Head formed", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "Blazing sword formed", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "Robeast destroyed", is_unplanned => FALSE, } ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, descriptive_trailing => { results => [ { actual_passed => TRUE, is_actual_ok => TRUE, description => "Interlock activated", passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "Megathrusters are go", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "Head formed", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "Blazing sword formed", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "Robeast destroyed", is_unplanned => FALSE, }, { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, empty => { results => [], plan => '', passed => [], actual_passed => [], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, is_good_plan => FALSE, tests_planned => undef, tests_run => 0, parse_errors => ['No plan found in TAP output'], 'exit' => 0, wait => 0, version => 12, }, simple => { results => [ { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, space_after_plan => { results => [ { is_plan => TRUE, raw => '1..5 ', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, simple_yaml => { results => [ { is_version => TRUE, raw => 'TAP version 13', }, { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { is_yaml => TRUE, data => [ { 'fnurk' => 'skib', 'ponk' => 'gleeb' }, { 'bar' => 'krup', 'foo' => 'plink' } ], raw => " ---\n -\n fnurk: skib\n ponk: gleeb\n -\n bar: krup\n foo: plink\n ...", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { is_yaml => TRUE, data => { 'got' => [ '1', 'pong', '4' ], 'expected' => [ '1', '2', '4' ] }, raw => " ---\n expected:\n - 1\n - 2\n - 4\n got:\n - 1\n - pong\n - 4\n ...", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 13, }, simple_fail => { results => [ { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1, 3, 4 ], actual_passed => [ 1, 3, 4 ], failed => [ 2, 5 ], actual_failed => [ 2, 5 ], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, skip => { results => [ { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => TRUE, has_todo => FALSE, number => 2, description => "", explanation => 'rain delay', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [2], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, skip_nomsg => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..1', tests_planned => 1, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => TRUE, has_todo => FALSE, number => 1, description => "", explanation => '', }, ], plan => '1..1', passed => [1], actual_passed => [1], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [1], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 1, tests_run => TRUE, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, todo_inline => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..3', tests_planned => 3, }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => TRUE, number => 1, description => "- Foo", explanation => 'Just testing the todo interface.', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => TRUE, number => 2, description => "- Unexpected success", explanation => 'Just testing the todo interface.', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "- This is not todo", explanation => '', }, ], plan => '1..3', passed => [ 1, 2, 3 ], actual_passed => [ 2, 3 ], failed => [], actual_failed => [1], todo => [ 1, 2 ], todo_passed => [2], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 3, tests_run => 3, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, todo => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..5 todo 3 2;', tests_planned => 5, todo_list => [ 3, 2 ], }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => TRUE, number => 2, description => "", explanation => '', }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => TRUE, number => 3, description => "", explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", explanation => '', }, ], plan => '1..5', passed => [ 1, 2, 3, 4, 5 ], actual_passed => [ 1, 2, 4, 5 ], failed => [], actual_failed => [3], todo => [ 2, 3 ], todo_passed => [2], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, duplicates => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..10', tests_planned => 10, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 6, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 7, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 8, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 9, description => '', explanation => '', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 10, description => '', explanation => '', is_unplanned => TRUE, }, ], plan => '1..10', passed => [ 1 .. 4, 4 .. 9 ], actual_passed => [ 1 .. 4, 4 .. 10 ], failed => [10], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, tests_planned => 10, tests_run => 11, parse_errors => [ 'Tests out of sequence. Found (4) but expected (5)', 'Tests out of sequence. Found (5) but expected (6)', 'Tests out of sequence. Found (6) but expected (7)', 'Tests out of sequence. Found (7) but expected (8)', 'Tests out of sequence. Found (8) but expected (9)', 'Tests out of sequence. Found (9) but expected (10)', 'Tests out of sequence. Found (10) but expected (11)', 'Bad plan. You planned 10 tests but ran 11.', ], 'exit' => 0, wait => 0, }, no_nums => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..5', tests_planned => 5, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => "", passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", } ], plan => '1..5', passed => [ 1, 2, 4, 5 ], actual_passed => [ 1, 2, 4, 5 ], failed => [3], actual_failed => [3], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, bailout => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..5', tests_planned => 5, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => "", passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { is_bailout => TRUE, explanation => "GERONIMMMOOOOOO!!!", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", } ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, no_output => { results => [], plan => '', passed => [], actual_passed => [], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, tests_planned => undef, tests_run => 0, parse_errors => [ 'No plan found in TAP output', ], 'exit' => 0, wait => 0, }, too_many => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..3', tests_planned => 3, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => "", passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", is_unplanned => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", is_unplanned => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 6, description => "", is_unplanned => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 7, description => "", is_unplanned => TRUE, }, ], plan => '1..3', passed => [ 1 .. 3 ], actual_passed => [ 1 .. 7 ], failed => [ 4 .. 7 ], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, tests_planned => 3, tests_run => 7, parse_errors => ['Bad plan. You planned 3 tests but ran 7.'], 'exit' => 4, wait => NOT_ZERO, skip_if => sub {$IsVMS}, }, taint => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..1', tests_planned => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => "- -T honored", passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, }, ], plan => '1..1', passed => [ 1 .. 1 ], actual_passed => [ 1 .. 1 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => TRUE, tests_run => TRUE, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, 'die' => { results => [], plan => '', passed => [], actual_passed => [], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, tests_planned => undef, tests_run => 0, parse_errors => [ 'No plan found in TAP output', ], 'exit' => NOT_ZERO, wait => NOT_ZERO, }, die_head_end => { results => [ { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '', explanation => '', }, ], plan => '', passed => [ 1 .. 4 ], actual_passed => [ 1 .. 4 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, tests_planned => undef, tests_run => 4, parse_errors => [ 'No plan found in TAP output', ], 'exit' => NOT_ZERO, wait => NOT_ZERO, }, die_last_minute => { results => [ { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '', explanation => '', }, { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..4', tests_planned => 4, }, ], plan => '1..4', passed => [ 1 .. 4 ], actual_passed => [ 1 .. 4 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 4, tests_run => 4, parse_errors => [], 'exit' => NOT_ZERO, wait => NOT_ZERO, }, bignum => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..2', tests_planned => 2, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 136211425, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 136211426, description => '', explanation => '', }, ], plan => '1..2', passed => [ 1, 2 ], actual_passed => [ 1, 2, 136211425, 136211426 ], failed => [ 136211425, 136211426 ], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, tests_planned => 2, tests_run => 4, parse_errors => [ 'Tests out of sequence. Found (136211425) but expected (3)', 'Tests out of sequence. Found (136211426) but expected (4)', 'Bad plan. You planned 2 tests but ran 4.' ], 'exit' => 0, wait => 0, }, bignum_many => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..2', tests_planned => 2, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 99997, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 99998, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 99999, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 100000, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 100001, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 100002, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 100003, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 100004, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 100005, description => '', explanation => '', }, ], plan => '1..2', passed => [ 1, 2 ], actual_passed => [ 1, 2, 99997 .. 100005 ], failed => [ 99997 .. 100005 ], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, tests_planned => 2, tests_run => 11, parse_errors => [ 'Tests out of sequence. Found (99997) but expected (3)', 'Tests out of sequence. Found (99998) but expected (4)', 'Tests out of sequence. Found (99999) but expected (5)', 'Tests out of sequence. Found (100000) but expected (6)', 'Tests out of sequence. Found (100001) but expected (7)', 'Tests out of sequence. Found (100002) but expected (8)', 'Tests out of sequence. Found (100003) but expected (9)', 'Tests out of sequence. Found (100004) but expected (10)', 'Tests out of sequence. Found (100005) but expected (11)', 'Bad plan. You planned 2 tests but ran 11.' ], 'exit' => 0, wait => 0, }, combined => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..10', tests_planned => 10, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => 'basset hounds got long ears', explanation => '', }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => 'all hell broke loose', explanation => '', }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => TRUE, number => 4, description => '', explanation => 'if I heard a voice from heaven ...', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => 'say "live without loving",', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 6, description => "I'd beg off.", explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => '1', has_todo => FALSE, number => 7, description => '', explanation => 'contract negotiations', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 8, description => 'Girls are such exquisite hell', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => TRUE, number => 9, description => 'Elegy 9B', explanation => '', }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 10, description => '', explanation => '', }, ], plan => '1..10', passed => [ 1 .. 2, 4 .. 9 ], actual_passed => [ 1 .. 2, 5 .. 9 ], failed => [ 3, 10 ], actual_failed => [ 3, 4, 10 ], todo => [ 4, 9 ], todo_passed => [9], skipped => [7], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 10, tests_run => 10, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, head_end => { results => [ { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'comments', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '', explanation => '', }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'comment', }, { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..4', tests_planned => 4, }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'more ignored stuff', }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'and yet more', }, ], plan => '1..4', passed => [ 1 .. 4 ], actual_passed => [ 1 .. 4 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 4, tests_run => 4, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, head_fail => { results => [ { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'comments', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '', explanation => '', }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'comment', }, { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..4', tests_planned => 4, }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'more ignored stuff', }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'and yet more', }, ], plan => '1..4', passed => [ 1, 3, 4 ], actual_passed => [ 1, 3, 4 ], failed => [2], actual_failed => [2], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 4, tests_run => 4, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, out_of_order => { results => [ { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '- Test that argument passing works', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => '- Test that passing arguments as references work', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '- Test a normal sub', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 6, description => '- Detach test', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 8, description => '- Nested thread test', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 9, description => '- Nested thread test', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 10, description => '- Wanted 7, got 7', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 11, description => '- Wanted 7, got 7', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 12, description => '- Wanted 8, got 8', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 13, description => '- Wanted 8, got 8', explanation => '', }, { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..15', tests_planned => 15, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => '- Check that Config::threads is true', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 7, description => '- Detach test', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 14, description => '- Check so that tid for threads work for main thread', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 15, description => '- Check so that tid for threads work for main thread', explanation => '', }, ], plan => '1..15', passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], actual_passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], is_good_plan => FALSE, tests_planned => 15, tests_run => 15, # Note that tests 14 and 15 *are* in the correct sequence. parse_errors => [ 'Tests out of sequence. Found (2) but expected (1)', 'Tests out of sequence. Found (3) but expected (2)', 'Tests out of sequence. Found (4) but expected (3)', 'Tests out of sequence. Found (6) but expected (4)', 'Tests out of sequence. Found (8) but expected (5)', 'Tests out of sequence. Found (9) but expected (6)', 'Tests out of sequence. Found (10) but expected (7)', 'Tests out of sequence. Found (11) but expected (8)', 'Tests out of sequence. Found (12) but expected (9)', 'Tests out of sequence. Found (13) but expected (10)', 'Plan (1..15) must be at the beginning or end of the TAP output', 'Tests out of sequence. Found (1) but expected (11)', 'Tests out of sequence. Found (5) but expected (12)', 'Tests out of sequence. Found (7) but expected (13)', ], 'exit' => 0, wait => 0, }, skipall => { results => [ { is_plan => TRUE, raw => '1..0 # skipping: rope', tests_planned => 0, passed => TRUE, is_ok => TRUE, directive => 'SKIP', explanation => 'rope' }, ], plan => '1..0', passed => [], actual_passed => [], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 0, tests_run => 0, parse_errors => [], 'exit' => 0, wait => 0, version => 12, skip_all => 'rope', }, skipall_v13 => { results => [ { is_version => TRUE, raw => 'TAP version 13', }, { is_unknown => TRUE, raw => '1..0 # skipping: rope', }, ], plan => '', passed => [], actual_passed => [], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => FALSE, is_good_plan => FALSE, tests_planned => FALSE, tests_run => 0, parse_errors => ['No plan found in TAP output'], 'exit' => 0, wait => 0, version => 13, }, strict => { results => [ { is_version => TRUE, raw => 'TAP version 13', }, { is_plan => TRUE, raw => '1..1', }, { is_pragma => TRUE, raw => 'pragma +strict', pragmas => ['+strict'], }, { is_unknown => TRUE, raw => 'Nonsense!', }, { is_pragma => TRUE, raw => 'pragma -strict', pragmas => ['-strict'], }, { is_unknown => TRUE, raw => "Doesn't matter.", }, { is_test => TRUE, raw => 'ok 1 All OK', } ], plan => '1..1', passed => [1], actual_passed => [1], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 1, tests_run => 1, parse_errors => ['Unknown TAP token: "Nonsense!"'], 'exit' => 0, # TODO: Is this right??? wait => 0, version => 13, }, skipall_nomsg => { results => [ { is_plan => TRUE, raw => '1..0', tests_planned => 0, passed => TRUE, is_ok => TRUE, directive => 'SKIP', explanation => '' }, ], plan => '1..0', passed => [], actual_passed => [], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 0, tests_run => 0, parse_errors => [], 'exit' => 0, wait => 0, version => 12, skip_all => '(no reason given)', }, todo_misparse => { results => [ { is_plan => TRUE, raw => '1..1', tests_planned => TRUE, passed => TRUE, is_ok => TRUE, }, { actual_passed => FALSE, is_actual_ok => FALSE, passed => FALSE, is_ok => FALSE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => 'Hamlette # TODOORNOTTODO', explanation => '', }, ], plan => '1..1', passed => [], actual_passed => [], failed => [1], actual_failed => [1], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => TRUE, tests_run => 1, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, shbang_misparse => { results => [ { is_plan => TRUE, raw => '1..2', tests_planned => 2, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => "", passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, ], plan => '1..2', passed => [ 1 .. 2 ], actual_passed => [ 1 .. 2 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 2, tests_run => 2, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, switches => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..1', tests_planned => 1, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", explanation => '', }, ], __ARGS__ => { switches => ['-Mstrict'] }, plan => '1..1', passed => [1], actual_passed => [1], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 1, tests_run => TRUE, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, inc_taint => { results => [ { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..1', tests_planned => 1, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", explanation => '', }, ], __ARGS__ => { switches => ['-Iexamples'] }, plan => '1..1', passed => [1], actual_passed => [1], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 1, tests_run => TRUE, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, sequence_misparse => { results => [ { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "\# skipped on foobar system", }, { is_comment => TRUE, comment => '1234567890123456789012345678901234567890', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { is_comment => TRUE, comment => '1234567890123456789012345678901234567890', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, # For some reason mixing stdout with stderr is unreliable on Windows ( $IsWin32 ? () : ( stdout_stderr => { results => [ { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'comments', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => '', explanation => '', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => '', explanation => '', }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'comment', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => '', explanation => '', }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'more ignored stuff', }, { is_comment => TRUE, passed => TRUE, is_ok => TRUE, comment => 'and yet more', }, { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..4', tests_planned => 4, }, ], plan => '1..4', passed => [ 1 .. 4 ], actual_passed => [ 1 .. 4 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 4, tests_run => 4, parse_errors => [], 'exit' => 0, wait => 0, version => 12, need_open3 => 1, } ) ), junk_before_plan => { results => [ { is_unknown => TRUE, raw => 'this is junk', }, { is_comment => TRUE, comment => "this is a comment", }, { is_plan => TRUE, passed => TRUE, is_ok => TRUE, raw => '1..1', tests_planned => 1, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, }, ], plan => '1..1', passed => [ 1 .. 1 ], actual_passed => [ 1 .. 1 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 1, tests_run => 1, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, version_good => { results => [ { is_version => TRUE, raw => 'TAP version 13', }, { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [], 'exit' => 0, wait => 0, version => 13, }, version_old => { results => [ { is_version => TRUE, raw => 'TAP version 12', }, { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => ['Explicit TAP version must be at least 13. Got version 12'], 'exit' => 0, wait => 0, version => 12, }, version_late => { results => [ { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { is_version => TRUE, raw => 'TAP version 13', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 4, description => "", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, description => "", }, ], plan => '1..5', passed => [ 1 .. 5 ], actual_passed => [ 1 .. 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => ['If TAP version is present it must be the first line of output'], 'exit' => 0, wait => 0, version => 12, }, escape_eol => { results => [ { is_plan => TRUE, raw => '1..2', tests_planned => 2, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => 'Should parse as literal backslash --> \\', passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => 'Not a continuation line', is_unplanned => FALSE, }, ], plan => '1..2', passed => [ 1 .. 2 ], actual_passed => [ 1 .. 2 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 2, tests_run => 2, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, escape_hash => { results => [ { is_plan => TRUE, raw => '1..3', tests_planned => 3, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => 'Not a \\# TODO', passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => 'Not a \\# SKIP', is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => 'Escaped \\\\\\#', is_unplanned => FALSE, }, ], plan => '1..3', passed => [ 1 .. 3 ], actual_passed => [ 1 .. 3 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 3, tests_run => 3, parse_errors => [], 'exit' => 0, wait => 0, version => 12, }, zero_valid => { results => [ { is_plan => TRUE, raw => '1..5', tests_planned => 5, passed => TRUE, is_ok => TRUE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => '- One', passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => '- Two', passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => '- Three', passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => '- Four', passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 0, is_unplanned => FALSE, }, { actual_passed => TRUE, is_actual_ok => TRUE, description => '- Five', passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 5, is_unplanned => FALSE, }, ], plan => '1..5', passed => [ 1 .. 3, 0, 5 ], actual_passed => [ 1 .. 3, 0, 5 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 5, tests_run => 5, parse_errors => [ 'Tests out of sequence. Found (0) but expected (4)', ], 'exit' => 0, wait => 0, version => 12, }, yaml_late_plan => { results => [ { is_version => TRUE, raw => 'TAP version 13', }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 1, description => "- test suite started", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 2, description => "- bogomips", }, { is_yaml => TRUE, data => { 'Bogomips' => '5226.88' }, raw => " ---\n Bogomips: 5226.88\n ...", }, { actual_passed => TRUE, is_actual_ok => TRUE, passed => TRUE, is_ok => TRUE, is_test => TRUE, has_skip => FALSE, has_todo => FALSE, number => 3, description => "- test suite finished", }, { is_plan => TRUE, raw => '1..3', tests_planned => 3, passed => TRUE, is_ok => TRUE, }, ], plan => '1..3', passed => [ 1 .. 3 ], actual_passed => [ 1 .. 3 ], failed => [], actual_failed => [], todo => [], todo_passed => [], skipped => [], good_plan => TRUE, is_good_plan => TRUE, tests_planned => 3, tests_run => 3, parse_errors => [], 'exit' => 0, wait => 0, version => 13, }, ); my %HANDLER_FOR = ( NOT_ZERO, sub { no warnings; 0 != shift }, TRUE, sub { no warnings; !!shift }, FALSE, sub { no warnings; !shift }, ); my $can_open3 = ( $Config{d_fork} || $IsWin32 ) ? 1 : 0; for my $hide_fork ( 0 .. $can_open3 ) { if ($hide_fork) { no strict 'refs'; no warnings 'redefine'; *{'TAP::Parser::Iterator::Process::_use_open3'} = sub {return}; } TEST: for my $test ( sort keys %samples ) { #next unless 'empty' eq $test; my %details = %{ $samples{$test} }; if ( my $skip_if = delete $details{skip_if} ) { next TEST if $skip_if->(); } my $results = delete $details{results}; my $args = delete $details{__ARGS__}; my $need_open3 = delete $details{need_open3}; next TEST if $need_open3 && ( $hide_fork || !$can_open3 ); # the following acrobatics are necessary to make it easy for the # Test::Builder::failure_output() method to be overridden when # TAP::Parser is not installed. Otherwise, these tests will fail. unshift @{ $args->{switches} }, $ENV{PERL_CORE} ? ( map {"-I$_"} @INC ) : ('-It/lib'); $args->{source} = File::Spec->catfile( $SAMPLE_TESTS, $test ); $args->{merge} = !$hide_fork; my $parser = eval { analyze_test( $test, [@$results], $args ) }; my $error = $@; ok !$error, "'$test' should parse successfully" or diag $error; if ($error) { my $tests = 0; while ( my ( $method, $answer ) = each %details ) { $tests += ref $answer ? 2 : 1; } SKIP: { skip "$test did not parse successfully", $tests; } } else { while ( my ( $method, $answer ) = each %details ) { if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck ok $handler->( $parser->$method() ), "... and $method should return a reasonable value ($test)"; } elsif ( !ref $answer ) { no warnings 'uninitialized'; $answer = _vmsify_answer( $method, $answer ); is $parser->$method(), $answer, "... and $method should equal $answer ($test)"; } else { is scalar $parser->$method(), scalar @$answer, "... and $method should be the correct amount ($test)"; is_deeply [ $parser->$method() ], $answer, "... and $method should be the correct values ($test)"; } } } } } my %Unix2VMS_Exit_Codes = ( 1 => 4, ); sub _vmsify_answer { my ( $method, $answer ) = @_; return $answer unless $IsVMS; if ( $method eq 'exit' and exists $Unix2VMS_Exit_Codes{$answer} ) { $answer = $Unix2VMS_Exit_Codes{$answer}; } return $answer; } sub analyze_test { my ( $test, $results, $args ) = @_; my $parser = TAP::Parser->new($args); my $count = 1; while ( defined( my $result = $parser->next ) ) { my $expected = shift @$results; my $desc = $result->is_test ? $result->description : $result->raw; $desc = $result->plan if $result->is_plan && $desc =~ /SKIP/i; $desc =~ s/#//g; $desc =~ s/\s+/ /g; # Drop newlines ok defined $expected, "$test/$count We should have a result for $desc"; while ( my ( $method, $answer ) = each %$expected ) { if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck ok $handler->( $result->$method() ), "... and $method should return a reasonable value ($test/$count)"; } elsif ( ref $answer ) { is_deeply scalar( $result->$method() ), $answer, "... and $method should return the correct structure ($test/$count)"; } else { is $result->$method(), $answer, "... and $method should return the correct answer ($test/$count)"; } } $count++; } is @$results, 0, "... and we should have the correct number of results ($test)"; return $parser; } # vms_nit Test-Harness-3.36/t/subclass_tests/0000755000175000017500000000000012640746441015755 5ustar leonleonTest-Harness-3.36/t/subclass_tests/perl_source0000644000175000017500000000011312166360606020213 0ustar leonleon#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - this is a test END_TESTS Test-Harness-3.36/t/subclass_tests/non_perl_source0000644000175000017500000000006312166360606021071 0ustar leonleon#!/bin/sh echo "1..1" echo "ok 1 - this is a test" Test-Harness-3.36/t/harness-subclass.t0000644000175000017500000000312112426525313016351 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use TAP::Harness; use Test::More tests => 13; my %class_map = ( aggregator_class => 'My::TAP::Parser::Aggregator', formatter_class => 'My::TAP::Formatter::Console', multiplexer_class => 'My::TAP::Parser::Multiplexer', parser_class => 'My::TAP::Parser', scheduler_class => 'My::TAP::Parser::Scheduler', ); my %loaded = (); # Synthesize our subclasses for my $class ( values %class_map ) { ( my $base_class = $class ) =~ s/^My:://; use_ok($base_class); no strict 'refs'; @{"${class}::ISA"} = ($base_class); *{"${class}::new"} = sub { my $pkg = shift; $loaded{$pkg} = 1; # Can't use SUPER outside a package return $base_class->can('new')->( $pkg, @_ ); }; } { ok my $harness = TAP::Harness->new( { %class_map, verbosity => -9 } ), 'created harness'; isa_ok $harness, 'TAP::Harness'; # Test dynamic loading ok !$INC{'NOP.pm'}, 'NOP not loaded'; ok my $nop = $harness->_construct('NOP'), 'loaded and created'; isa_ok $nop, 'NOP'; ok $INC{'NOP.pm'}, 'NOP loaded'; my $aggregate = $harness->runtests( File::Spec->catfile( 't', 'sample-tests', 'simple' ) ); isa_ok $aggregate, 'My::TAP::Parser::Aggregator'; is_deeply \%loaded, { 'My::TAP::Parser::Aggregator' => 1, 'My::TAP::Formatter::Console' => 1, 'My::TAP::Parser' => 1, 'My::TAP::Parser::Scheduler' => 1, }, 'loaded our classes'; } Test-Harness-3.36/t/file.t0000644000175000017500000003316012426525314014017 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More; use TAP::Harness; my $HARNESS = 'TAP::Harness'; my $source_tests = 't/source_tests'; my $sample_tests = 't/sample-tests'; plan tests => 56; # note that this test will always pass when run through 'prove' ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set'; { my @output; no warnings 'redefine'; require TAP::Formatter::Base; local *TAP::Formatter::Base::_output = sub { my $self = shift; push @output => grep { $_ ne '' } map { local $_ = $_; chomp; trim($_) } map { split /\n/ } @_; }; # Make sure verbosity 1 overrides failures and comments. my $harness = TAP::Harness->new( { verbosity => 1, failures => 1, comments => 1, } ); my $harness_whisper = TAP::Harness->new( { verbosity => -1 } ); my $harness_mute = TAP::Harness->new( { verbosity => -2 } ); my $harness_directives = TAP::Harness->new( { directives => 1 } ); my $harness_failures = TAP::Harness->new( { failures => 1 } ); my $harness_comments = TAP::Harness->new( { comments => 1 } ); my $harness_fandc = TAP::Harness->new( { failures => 1, comments => 1 } ); can_ok $harness, 'runtests'; # normal tests in verbose mode ok my $aggregate = _runtests( $harness, "$source_tests/harness" ), '... runtests returns the aggregate'; isa_ok $aggregate, 'TAP::Parser::Aggregator'; chomp(@output); my @expected = ( "$source_tests/harness ..", '1..1', 'ok 1 - this is a test', 'ok', 'All tests successful.', ); my $status = pop @output; my $expected_status = qr{^Result: PASS$}; my $summary = pop @output; my $expected_summary = qr{^Files=1, Tests=1, +\d+ wallclock secs}; is_deeply \@output, \@expected, '... the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # use an alias for test name @output = (); ok $aggregate = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ), 'runtests returns the aggregate'; isa_ok $aggregate, 'TAP::Parser::Aggregator'; chomp(@output); @expected = ( 'My Nice Test ..', '1..1', 'ok 1 - this is a test', 'ok', 'All tests successful.', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr{^Files=1, Tests=1, +\d+ wallclock secs}; is_deeply \@output, \@expected, '... the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # run same test twice @output = (); ok $aggregate = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ], [ "$source_tests/harness", 'My Nice Test Again' ] ), 'runtests labels returns the aggregate'; isa_ok $aggregate, 'TAP::Parser::Aggregator'; chomp(@output); @expected = ( 'My Nice Test ........', '1..1', 'ok 1 - this is a test', 'ok', 'My Nice Test Again ..', '1..1', 'ok 1 - this is a test', 'ok', 'All tests successful.', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr{^Files=2, Tests=2, +\d+ wallclock secs}; is_deeply \@output, \@expected, '... the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # normal tests in quiet mode @output = (); ok _runtests( $harness_whisper, "$source_tests/harness" ), 'Run tests with whisper'; chomp(@output); @expected = ( "$source_tests/harness .. ok", 'All tests successful.', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr/^Files=1, Tests=1, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # normal tests in really_quiet mode @output = (); ok _runtests( $harness_mute, "$source_tests/harness" ), 'Run tests mute'; chomp(@output); @expected = ( 'All tests successful.', ); $status = pop @output; $expected_status = qr{^Result: PASS$}; $summary = pop @output; $expected_summary = qr/^Files=1, Tests=1, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... the output should be correct'; like $status, $expected_status, '... and the status line should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; # normal tests with failures @output = (); ok _runtests( $harness, "$source_tests/harness_failure" ), 'Run tests with failures'; $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... the status line should be correct'; my @summary = @output[ 9 .. $#output ]; @output = @output[ 0 .. 8 ]; @expected = ( "$source_tests/harness_failure ..", '1..2', 'ok 1 - this is a test', 'not ok 2 - this is another test', q{# Failed test 'this is another test'}, '# in harness_failure.t at line 5.', q{# got: 'waffle'}, q{# expected: 'yarblokos'}, 'Failed 1/2 subtests', ); is_deeply \@output, \@expected, '... and failing test output should be correct'; my @expected_summary = ( 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); is_deeply \@summary, \@expected_summary, '... and the failure summary should also be correct'; # quiet tests with failures @output = (); ok _runtests( $harness_whisper, "$source_tests/harness_failure" ), 'Run whisper tests with failures'; $status = pop @output; $summary = pop @output; @expected = ( "$source_tests/harness_failure ..", 'Failed 1/2 subtests', 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); like $status, qr{^Result: FAIL$}, '... the status line should be correct'; is_deeply \@output, \@expected, '... and failing test output should be correct'; # really quiet tests with failures @output = (); ok _runtests( $harness_mute, "$source_tests/harness_failure" ), 'Run mute tests with failures'; $status = pop @output; $summary = pop @output; @expected = ( 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); like $status, qr{^Result: FAIL$}, '... the status line should be correct'; is_deeply \@output, \@expected, '... and failing test output should be correct'; # only show directives @output = (); ok _runtests( $harness_directives, "$source_tests/harness_directives" ), 'Run tests with directives'; chomp(@output); @expected = ( "$source_tests/harness_directives ..", 'not ok 2 - we have a something # TODO some output', "ok 3 houston, we don't have liftoff # SKIP no funding", 'ok', 'All tests successful.', # ~TODO {{{ this should be an option #'Test Summary Report', #'-------------------', #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)", #'Tests skipped:', #'3', # }}} ); $status = pop @output; $summary = pop @output; $expected_summary = qr/^Files=1, Tests=3, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... the output should be correct'; like $summary, $expected_summary, '... and the report summary should look correct'; like $status, qr{^Result: PASS$}, '... and the status line should be correct'; # normal tests with bad tap @output = (); ok _runtests( $harness, "$source_tests/harness_badtap" ), 'Run tests with bad TAP'; chomp(@output); @output = map { trim($_) } @output; $status = pop @output; @summary = @output[ 6 .. ( $#output - 1 ) ]; @output = @output[ 0 .. 5 ]; @expected = ( "$source_tests/harness_badtap ..", '1..2', 'ok 1 - this is a test', 'not ok 2 - this is another test', '1..2', 'Failed 1/2 subtests', ); is_deeply \@output, \@expected, '... failing test output should be correct'; like $status, qr{^Result: FAIL$}, '... and the status line should be correct'; @expected_summary = ( 'Test Summary Report', '-------------------', "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', 'Parse errors: More than one plan found in TAP output', ); is_deeply \@summary, \@expected_summary, '... and the badtap summary should also be correct'; # coverage testing for _should_show_failures # only show failures @output = (); ok _runtests( $harness_failures, "$source_tests/harness_failure" ), 'Run tests with failures only'; chomp(@output); @expected = ( "$source_tests/harness_failure ..", 'not ok 2 - this is another test', 'Failed 1/2 subtests', 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... the status line should be correct'; $expected_summary = qr/^Files=1, Tests=2, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; # check the status output for no tests @output = (); ok _runtests( $harness_failures, "$sample_tests/no_output" ), 'Run tests with failures'; chomp(@output); @expected = ( "$sample_tests/no_output ..", 'No subtests run', 'Test Summary Report', '-------------------', "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)", 'Parse errors: No plan found in TAP output', ); $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... the status line should be correct'; $expected_summary = qr/^Files=1, Tests=2, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; # coverage testing for _should_show_comments # only show comments @output = (); ok _runtests( $harness_comments, "$source_tests/harness_failure" ), 'Run tests with comments'; chomp(@output); @expected = ( "$source_tests/harness_failure ..", q{# Failed test 'this is another test'}, '# in harness_failure.t at line 5.', q{# got: 'waffle'}, q{# expected: 'yarblokos'}, 'Failed 1/2 subtests', 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... the status line should be correct'; $expected_summary = qr/^Files=1, Tests=2, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; # coverage testing for _should_show_comments and _should_show_failures # only show comments and failures @output = (); $ENV{FOO} = 1; ok _runtests( $harness_fandc, "$source_tests/harness_failure" ), 'Run tests with failures and comments'; delete $ENV{FOO}; chomp(@output); @expected = ( "$source_tests/harness_failure ..", 'not ok 2 - this is another test', q{# Failed test 'this is another test'}, '# in harness_failure.t at line 5.', q{# got: 'waffle'}, q{# expected: 'yarblokos'}, 'Failed 1/2 subtests', 'Test Summary Report', '-------------------', "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", 'Failed test:', '2', ); $status = pop @output; $summary = pop @output; like $status, qr{^Result: FAIL$}, '... the status line should be correct'; $expected_summary = qr/^Files=1, Tests=2, +\d+ wallclock secs/; is_deeply \@output, \@expected, '... and the output should be correct'; #XXXX } sub trim { $_[0] =~ s/^\s+|\s+$//g; return $_[0]; } sub _runtests { my ( $harness, @tests ) = @_; local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; my $aggregate = $harness->runtests(@tests); return $aggregate; } Test-Harness-3.36/t/parse.t0000755000175000017500000007574012426525317014232 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; BEGIN { use lib 't/lib'; } use Test::More tests => 294; use IO::c55Capture; use File::Spec; use TAP::Parser; use TAP::Parser::Iterator::Array; sub _get_results { my $parser = shift; my @results; while ( defined( my $result = $parser->next ) ) { push @results => $result; } return @results; } my ( $PARSER, $PLAN, $PRAGMA, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw( TAP::Parser TAP::Parser::Result::Plan TAP::Parser::Result::Pragma TAP::Parser::Result::Test TAP::Parser::Result::Comment TAP::Parser::Result::Bailout TAP::Parser::Result::Unknown TAP::Parser::Result::YAML TAP::Parser::Result::Version ); my $tap = <<'END_TAP'; TAP version 13 1..7 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure --- YAML! ... ok 5 # skip we have no description ok 6 - you shall not pass! # TODO should have failed not ok 7 - Gandalf wins. Game over. # TODO 'bout time! END_TAP can_ok $PARSER, 'new'; my $parser = $PARSER->new( { tap => $tap } ); isa_ok $parser, $PARSER, '... and the object it returns'; ok $ENV{TAP_VERSION}, 'TAP_VERSION env variable should be set'; # results() is sane? my @results = _get_results($parser); is scalar @results, 12, '... and there should be one for each line'; my $version = shift @results; isa_ok $version, $VERSION; is $version->version, '13', '... and the version should be 13'; # check the test plan my $result = shift @results; isa_ok $result, $PLAN; can_ok $result, 'type'; is $result->type, 'plan', '... and it should report the correct type'; ok $result->is_plan, '... and it should identify itself as a plan'; is $result->plan, '1..7', '... and identify the plan'; ok !$result->directive, '... and this plan should not have a directive'; ok !$result->explanation, '... or a directive explanation'; is $result->as_string, '1..7', '... and have the correct string representation'; is $result->raw, '1..7', '... and raw() should return the original line'; # a normal, passing test my $test = shift @results; isa_ok $test, $TEST; is $test->type, 'test', '... and it should report the correct type'; ok $test->is_test, '... and it should identify itself as a test'; is $test->ok, 'ok', '... and it should have the correct ok()'; ok $test->is_ok, '... and the correct boolean version of is_ok()'; ok $test->is_actual_ok, '... and the correct boolean version of is_actual_ok()'; is $test->number, 1, '... and have the correct test number'; is $test->description, '- input file opened', '... and the correct description'; ok !$test->directive, '... and not have a directive'; ok !$test->explanation, '... or a directive explanation'; ok !$test->has_skip, '... and it is not a SKIPped test'; ok !$test->has_todo, '... nor a TODO test'; is $test->as_string, 'ok 1 - input file opened', '... and its string representation should be correct'; is $test->raw, 'ok 1 - input file opened', '... and raw() should return the original line'; # junk lines should be preserved my $unknown = shift @results; isa_ok $unknown, $UNKNOWN; is $unknown->type, 'unknown', '... and it should report the correct type'; ok $unknown->is_unknown, '... and it should identify itself as unknown'; is $unknown->as_string, '... this is junk', '... and its string representation should be returned verbatim'; is $unknown->raw, '... this is junk', '... and raw() should return the original line'; # a failing test, which also happens to have a directive my $failed = shift @results; isa_ok $failed, $TEST; is $failed->type, 'test', '... and it should report the correct type'; ok $failed->is_test, '... and it should identify itself as a test'; is $failed->ok, 'not ok', '... and it should have the correct ok()'; ok $failed->is_ok, '... and TODO tests should always pass'; ok !$failed->is_actual_ok, '... and the correct boolean version of is_actual_ok ()'; is $failed->number, 2, '... and have the correct failed number'; is $failed->description, 'first line of the input valid', '... and the correct description'; is $failed->directive, 'TODO', '... and should have the correct directive'; is $failed->explanation, 'some data', '... and the correct directive explanation'; ok !$failed->has_skip, '... and it is not a SKIPped failed'; ok $failed->has_todo, '... but it is a TODO succeeded'; is $failed->as_string, 'not ok 2 first line of the input valid # TODO some data', '... and its string representation should be correct'; is $failed->raw, 'not ok first line of the input valid # todo some data', '... and raw() should return the original line'; # comments my $comment = shift @results; isa_ok $comment, $COMMENT; is $comment->type, 'comment', '... and it should report the correct type'; ok $comment->is_comment, '... and it should identify itself as a comment'; is $comment->comment, 'this is a comment', '... and you should be able to fetch the comment'; is $comment->as_string, '# this is a comment', '... and have the correct string representation'; is $comment->raw, '# this is a comment', '... and raw() should return the original line'; # another normal, passing test $test = shift @results; isa_ok $test, $TEST; is $test->type, 'test', '... and it should report the correct type'; ok $test->is_test, '... and it should identify itself as a test'; is $test->ok, 'ok', '... and it should have the correct ok()'; ok $test->is_ok, '... and the correct boolean version of is_ok()'; ok $test->is_actual_ok, '... and the correct boolean version of is_actual_ok()'; is $test->number, 3, '... and have the correct test number'; is $test->description, '- read the rest of the file', '... and the correct description'; ok !$test->directive, '... and not have a directive'; ok !$test->explanation, '... or a directive explanation'; ok !$test->has_skip, '... and it is not a SKIPped test'; ok !$test->has_todo, '... nor a TODO test'; is $test->as_string, 'ok 3 - read the rest of the file', '... and its string representation should be correct'; is $test->raw, 'ok 3 - read the rest of the file', '... and raw() should return the original line'; # a failing test $failed = shift @results; isa_ok $failed, $TEST; is $failed->type, 'test', '... and it should report the correct type'; ok $failed->is_test, '... and it should identify itself as a test'; is $failed->ok, 'not ok', '... and it should have the correct ok()'; ok !$failed->is_ok, '... and the tests should not have passed'; ok !$failed->is_actual_ok, '... and the correct boolean version of is_actual_ok ()'; is $failed->number, 4, '... and have the correct failed number'; is $failed->description, '- this is a real failure', '... and the correct description'; ok !$failed->directive, '... and should have no directive'; ok !$failed->explanation, '... and no directive explanation'; ok !$failed->has_skip, '... and it is not a SKIPped failed'; ok !$failed->has_todo, '... and not a TODO test'; is $failed->as_string, 'not ok 4 - this is a real failure', '... and its string representation should be correct'; is $failed->raw, 'not ok 4 - this is a real failure', '... and raw() should return the original line'; # Some YAML my $yaml = shift @results; isa_ok $yaml, $YAML; is $yaml->type, 'yaml', '... and it should report the correct type'; ok $yaml->is_yaml, '... and it should identify itself as yaml'; is_deeply $yaml->data, 'YAML!', '... and data should be correct'; # ok 5 # skip we have no description # skipped test $test = shift @results; isa_ok $test, $TEST; is $test->type, 'test', '... and it should report the correct type'; ok $test->is_test, '... and it should identify itself as a test'; is $test->ok, 'ok', '... and it should have the correct ok()'; ok $test->is_ok, '... and the correct boolean version of is_ok()'; ok $test->is_actual_ok, '... and the correct boolean version of is_actual_ok()'; is $test->number, 5, '... and have the correct test number'; ok !$test->description, '... and skipped tests have no description'; is $test->directive, 'SKIP', '... and the correct directive'; is $test->explanation, 'we have no description', '... but we should have an explanation'; ok $test->has_skip, '... and it is a SKIPped test'; ok !$test->has_todo, '... but not a TODO test'; is $test->as_string, 'ok 5 # SKIP we have no description', '... and its string representation should be correct'; is $test->raw, 'ok 5 # skip we have no description', '... and raw() should return the original line'; # a failing test, which also happens to have a directive # ok 6 - you shall not pass! # TODO should have failed my $bonus = shift @results; isa_ok $bonus, $TEST; can_ok $bonus, 'todo_passed'; is $bonus->type, 'test', 'TODO tests should parse correctly'; ok $bonus->is_test, '... and it should identify itself as a test'; is $bonus->ok, 'ok', '... and it should have the correct ok()'; ok $bonus->is_ok, '... and TODO tests should not always pass'; ok $bonus->is_actual_ok, '... and the correct boolean version of is_actual_ok ()'; is $bonus->number, 6, '... and have the correct failed number'; is $bonus->description, '- you shall not pass!', '... and the correct description'; is $bonus->directive, 'TODO', '... and should have the correct directive'; is $bonus->explanation, 'should have failed', '... and the correct directive explanation'; ok !$bonus->has_skip, '... and it is not a SKIPped failed'; ok $bonus->has_todo, '... but it is a TODO succeeded'; is $bonus->as_string, 'ok 6 - you shall not pass! # TODO should have failed', '... and its string representation should be correct'; is $bonus->raw, 'ok 6 - you shall not pass! # TODO should have failed', '... and raw() should return the original line'; ok $bonus->todo_passed, '... todo_bonus() should pass for TODO tests which unexpectedly succeed'; # not ok 7 - Gandalf wins. Game over. # TODO 'bout time! my $passed = shift @results; isa_ok $passed, $TEST; can_ok $passed, 'todo_passed'; is $passed->type, 'test', 'TODO tests should parse correctly'; ok $passed->is_test, '... and it should identify itself as a test'; is $passed->ok, 'not ok', '... and it should have the correct ok()'; ok $passed->is_ok, '... and TODO tests should always pass'; ok !$passed->is_actual_ok, '... and the correct boolean version of is_actual_ok ()'; is $passed->number, 7, '... and have the correct passed number'; is $passed->description, '- Gandalf wins. Game over.', '... and the correct description'; is $passed->directive, 'TODO', '... and should have the correct directive'; is $passed->explanation, "'bout time!", '... and the correct directive explanation'; ok !$passed->has_skip, '... and it is not a SKIPped passed'; ok $passed->has_todo, '... but it is a TODO succeeded'; is $passed->as_string, "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!", '... and its string representation should be correct'; is $passed->raw, "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!", '... and raw() should return the original line'; ok !$passed->todo_passed, '... todo_passed() should not pass for TODO tests which failed'; # test parse results can_ok $parser, 'passed'; is $parser->passed, 6, '... and we should have the correct number of passed tests'; is_deeply [ $parser->passed ], [ 1, 2, 3, 5, 6, 7 ], '... and get a list of the passed tests'; can_ok $parser, 'failed'; is $parser->failed, 1, '... and the correct number of failed tests'; is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests'; can_ok $parser, 'actual_passed'; is $parser->actual_passed, 4, '... and we should have the correct number of actually passed tests'; is_deeply [ $parser->actual_passed ], [ 1, 3, 5, 6 ], '... and get a list of the actually passed tests'; can_ok $parser, 'actual_failed'; is $parser->actual_failed, 3, '... and the correct number of actually failed tests'; is_deeply [ $parser->actual_failed ], [ 2, 4, 7 ], '... or get a list of the actually failed tests'; can_ok $parser, 'todo'; is $parser->todo, 3, '... and we should have the correct number of TODO tests'; is_deeply [ $parser->todo ], [ 2, 6, 7 ], '... and get a list of the TODO tests'; can_ok $parser, 'skipped'; is $parser->skipped, 1, '... and we should have the correct number of skipped tests'; is_deeply [ $parser->skipped ], [5], '... and get a list of the skipped tests'; # check the plan can_ok $parser, 'plan'; is $parser->plan, '1..7', '... and we should have the correct plan'; is $parser->tests_planned, 7, '... and the correct number of tests'; # "Unexpectedly succeeded" can_ok $parser, 'todo_passed'; is scalar $parser->todo_passed, 1, '... and it should report the number of tests which unexpectedly succeeded'; is_deeply [ $parser->todo_passed ], [6], '... or *which* tests unexpectedly succeeded'; # # Bug report from Torsten Schoenfeld # Makes sure parser can handle blank lines # $tap = <<'END_TAP'; 1..2 ok 1 - input file opened ok 2 - read the rest of the file END_TAP my $aref = [ split /\n/ => $tap ]; can_ok $PARSER, 'new'; $parser = $PARSER->new( { iterator => TAP::Parser::Iterator::Array->new($aref) } ); isa_ok $parser, $PARSER, '... and calling it should succeed'; # results() is sane? ok @results = _get_results($parser), 'The parser should return results'; is scalar @results, 5, '... and there should be one for each line'; # check the test plan $result = shift @results; isa_ok $result, $PLAN; can_ok $result, 'type'; is $result->type, 'plan', '... and it should report the correct type'; ok $result->is_plan, '... and it should identify itself as a plan'; is $result->plan, '1..2', '... and identify the plan'; is $result->as_string, '1..2', '... and have the correct string representation'; is $result->raw, '1..2', '... and raw() should return the original line'; # a normal, passing test $test = shift @results; isa_ok $test, $TEST; is $test->type, 'test', '... and it should report the correct type'; ok $test->is_test, '... and it should identify itself as a test'; is $test->ok, 'ok', '... and it should have the correct ok()'; ok $test->is_ok, '... and the correct boolean version of is_ok()'; ok $test->is_actual_ok, '... and the correct boolean version of is_actual_ok()'; is $test->number, 1, '... and have the correct test number'; is $test->description, '- input file opened', '... and the correct description'; ok !$test->directive, '... and not have a directive'; ok !$test->explanation, '... or a directive explanation'; ok !$test->has_skip, '... and it is not a SKIPped test'; ok !$test->has_todo, '... nor a TODO test'; is $test->as_string, 'ok 1 - input file opened', '... and its string representation should be correct'; is $test->raw, 'ok 1 - input file opened', '... and raw() should return the original line'; # junk lines should be preserved $unknown = shift @results; isa_ok $unknown, $UNKNOWN; is $unknown->type, 'unknown', '... and it should report the correct type'; ok $unknown->is_unknown, '... and it should identify itself as unknown'; is $unknown->as_string, '', '... and its string representation should be returned verbatim'; is $unknown->raw, '', '... and raw() should return the original line'; # ... and the second empty line $unknown = shift @results; isa_ok $unknown, $UNKNOWN; is $unknown->type, 'unknown', '... and it should report the correct type'; ok $unknown->is_unknown, '... and it should identify itself as unknown'; is $unknown->as_string, '', '... and its string representation should be returned verbatim'; is $unknown->raw, '', '... and raw() should return the original line'; # a passing test $test = shift @results; isa_ok $test, $TEST; is $test->type, 'test', '... and it should report the correct type'; ok $test->is_test, '... and it should identify itself as a test'; is $test->ok, 'ok', '... and it should have the correct ok()'; ok $test->is_ok, '... and the correct boolean version of is_ok()'; ok $test->is_actual_ok, '... and the correct boolean version of is_actual_ok()'; is $test->number, 2, '... and have the correct test number'; is $test->description, '- read the rest of the file', '... and the correct description'; ok !$test->directive, '... and not have a directive'; ok !$test->explanation, '... or a directive explanation'; ok !$test->has_skip, '... and it is not a SKIPped test'; ok !$test->has_todo, '... nor a TODO test'; is $test->as_string, 'ok 2 - read the rest of the file', '... and its string representation should be correct'; is $test->raw, 'ok 2 - read the rest of the file', '... and raw() should return the original line'; is scalar $parser->passed, 2, 'Empty junk lines should not affect the correct number of tests passed'; # Check source => "tap content" can_ok $PARSER, 'new'; $parser = $PARSER->new( { source => "1..1\nok 1\n" } ); isa_ok $parser, $PARSER, '... and calling it should succeed'; ok @results = _get_results($parser), 'The parser should return results'; is( scalar @results, 2, "Got two lines of TAP" ); # Check source => [array] can_ok $PARSER, 'new'; $parser = $PARSER->new( { source => [ "1..1", "ok 1" ] } ); isa_ok $parser, $PARSER, '... and calling it should succeed'; ok @results = _get_results($parser), 'The parser should return results'; is( scalar @results, 2, "Got two lines of TAP" ); # Check source => $filehandle can_ok $PARSER, 'new'; open my $fh, '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'; is( scalar @results, 2, "Got two lines of TAP" ); { # set a spool to write to tie local *SPOOL, 'IO::c55Capture'; my $tap = <<'END_TAP'; TAP version 13 1..7 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure --- YAML! ... ok 5 # skip we have no description ok 6 - you shall not pass! # TODO should have failed not ok 7 - Gandalf wins. Game over. # TODO 'bout time! END_TAP { my $parser = $PARSER->new( { tap => $tap, spool => \*SPOOL, } ); _get_results($parser); my @spooled = tied(*SPOOL)->dump(); is @spooled, 24, 'coverage testing for spool attribute of parser'; is join( '', @spooled ), $tap, "spooled tap matches"; } { my $parser = $PARSER->new( { tap => $tap, spool => \*SPOOL, } ); $parser->callback( 'ALL', sub { } ); _get_results($parser); my @spooled = tied(*SPOOL)->dump(); is @spooled, 24, 'coverage testing for spool attribute of parser'; is join( '', @spooled ), $tap, "spooled tap matches"; } } { # _initialize coverage my $x = bless [], 'kjsfhkjsdhf'; my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $PARSER->new(); }; is @die, 1, 'coverage testing for _initialize'; like pop @die, qr/PANIC:\s+could not determine iterator for input\s*at/, '...and it failed as expected'; @die = (); eval { local $SIG{__DIE__} = sub { push @die, @_ }; $PARSER->new( { iterator => 'iterator', tap => 'tap', source => 'source', # only one of these is allowed } ); }; is @die, 1, 'coverage testing for _initialize'; like pop @die, qr/You may only choose one of 'exec', 'tap', 'source' or 'iterator'/, '...and it failed as expected'; } { # coverage of todo_failed my $tap = <<'END_TAP'; TAP version 13 1..7 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure --- YAML! ... ok 5 # skip we have no description ok 6 - you shall not pass! # TODO should have failed not ok 7 - Gandalf wins. Game over. # TODO 'bout time! END_TAP my $parser = $PARSER->new( { tap => $tap } ); _get_results($parser); my @warn; eval { local $SIG{__WARN__} = sub { push @warn, @_ }; $parser->todo_failed; }; is @warn, 1, 'coverage testing of todo_failed'; like pop @warn, qr/"todo_failed" is deprecated. Please use "todo_passed". See the docs[.]/, '..and failed as expected' } { # coverage testing for T::P::_initialize # coverage of the source argument paths # ref argument to source my $parser = TAP::Parser->new( { source => [ split /$/, $tap ] } ); isa_ok $parser, 'TAP::Parser'; isa_ok $parser->_iterator, 'TAP::Parser::Iterator::Array'; SKIP: { skip 'Segfaults Perl 5.6.0' => 2 if $] <= 5.006000; # uncategorisable argument to source my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $parser = TAP::Parser->new( { source => 'nosuchfile' } ); }; is @die, 1, 'uncategorisable source'; like pop @die, qr/Cannot detect source of 'nosuchfile'/, '... and we died as expected'; } } { # coverage test of perl source with switches my $parser = TAP::Parser->new( { source => File::Spec->catfile( 't', 'sample-tests', 'simple' ), } ); isa_ok $parser, 'TAP::Parser'; isa_ok $parser->_iterator, 'TAP::Parser::Iterator::Process'; # Workaround for Mac OS X problem wrt closing the iterator without # reading from it. $parser->next; } { # coverage testing for TAP::Parser::has_problems # we're going to need to test lots of fragments of tap # to cover all the different boolean tests # currently covered are no problems and failed, so let's next test # todo_passed my $tap = <<'END_TAP'; TAP version 13 1..2 ok 1 - input file opened ok 2 - Gandalf wins. Game over. # TODO 'bout time! END_TAP my $parser = TAP::Parser->new( { tap => $tap } ); _get_results($parser); ok !$parser->failed, 'parser didnt fail'; ok $parser->todo_passed, '... and todo_passed is true'; ok !$parser->has_problems, '... and has_problems is false'; # now parse_errors $tap = <<'END_TAP'; TAP version 13 1..2 SMACK END_TAP $parser = TAP::Parser->new( { tap => $tap } ); _get_results($parser); ok !$parser->failed, 'parser didnt fail'; ok !$parser->todo_passed, '... and todo_passed is false'; ok $parser->parse_errors, '... and parse_errors is true'; ok $parser->has_problems, '... and has_problems'; # Now wait and exit are hard to do in an OS platform-independent way, so # we won't even bother $tap = <<'END_TAP'; TAP version 13 1..2 ok 1 - input file opened ok 2 - Gandalf wins END_TAP $parser = TAP::Parser->new( { tap => $tap } ); _get_results($parser); $parser->wait(1); ok !$parser->failed, 'parser didnt fail'; ok !$parser->todo_passed, '... and todo_passed is false'; ok !$parser->parse_errors, '... and parse_errors is false'; ok $parser->wait, '... and wait is set'; ok $parser->has_problems, '... and has_problems'; # and use the same for exit $parser->wait(0); $parser->exit(1); ok !$parser->failed, 'parser didnt fail'; ok !$parser->todo_passed, '... and todo_passed is false'; ok !$parser->parse_errors, '... and parse_errors is false'; ok !$parser->wait, '... and wait is not set'; ok $parser->exit, '... and exit is set'; ok $parser->has_problems, '... and has_problems'; } { # coverage testing of the version states my $tap = <<'END_TAP'; TAP version 12 1..2 ok 1 - input file opened ok 2 - Gandalf wins END_TAP my $parser = TAP::Parser->new( { tap => $tap } ); _get_results($parser); my @errors = $parser->parse_errors; is @errors, 1, 'test too low version number'; like pop @errors, qr/Explicit TAP version must be at least 13. Got version 12/, '... and trapped expected version error'; # now too high a version $tap = <<'END_TAP'; TAP version 14 1..2 ok 1 - input file opened ok 2 - Gandalf wins END_TAP $parser = TAP::Parser->new( { tap => $tap } ); _get_results($parser); @errors = $parser->parse_errors; is @errors, 1, 'test too high version number'; like pop @errors, qr/TAP specified version 14 but we don't know about versions later than 13/, '... and trapped expected version error'; } { # coverage testing of TAP version in the wrong place my $tap = <<'END_TAP'; 1..2 ok 1 - input file opened TAP version 12 ok 2 - Gandalf wins END_TAP my $parser = TAP::Parser->new( { tap => $tap } ); _get_results($parser); my @errors = $parser->parse_errors; is @errors, 1, 'test TAP version number in wrong place'; like pop @errors, qr/If TAP version is present it must be the first line of output/, '... and trapped expected version error'; } { # 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 iterator that dies when its next_raw method is called package TAP::Parser::Iterator::Dies; use strict; use base qw(TAP::Parser::Iterator); sub next_raw { die 'this is the dying iterator'; } # required as part of the TPI interface sub exit { } sub wait { } package main; # now build a standard parser my $tap = <<'END_TAP'; 1..2 ok 1 - input file opened ok 2 - Gandalf wins END_TAP { my $parser = TAP::Parser->new( { tap => $tap } ); # build a dying iterator my $iterator = TAP::Parser::Iterator::Dies->new; # now replace the iterator - we're forced to us an T::P intenal # method for this $parser->_iterator($iterator); # build a new grammar my $grammar = TAP::Parser::Grammar->new( { iterator => $iterator, parser => $parser } ); # replace our grammar with this new one $parser->_grammar($grammar); # now call next on the parser, and the grammar should die my $result = $parser->next; # will die in iterator is $result, undef, 'iterator dies'; my @errors = $parser->parse_errors; is @errors, 2, '...and caught expected errrors'; like shift @errors, qr/this is the dying iterator/, '...and it was what we expected'; } # Do it all again with callbacks to exercise the other code path in # the unrolled iterator { my $parser = TAP::Parser->new( { tap => $tap } ); $parser->callback( 'ALL', sub { } ); # build a dying iterator my $iterator = TAP::Parser::Iterator::Dies->new; # now replace the iterator - we're forced to us an T::P intenal # method for this $parser->_iterator($iterator); # build a new grammar my $grammar = TAP::Parser::Grammar->new( { iterator => $iterator, parser => $parser } ); # replace our grammar with this new one $parser->_grammar($grammar); # now call next on the parser, and the grammar should die my $result = $parser->next; # will die in iterator is $result, undef, 'iterator dies'; my @errors = $parser->parse_errors; is @errors, 2, '...and caught expected errrors'; like shift @errors, qr/this is the dying iterator/, '...and it was what we expected'; } } { # coverage testing of TAP::Parser::_next_state package TAP::Parser::WithBrokenState; use base qw( TAP::Parser ); sub _make_state_table { return { INIT => { plan => { goto => 'FOO' } } }; } package main; my $tap = <<'END_TAP'; 1..2 ok 1 - input file opened ok 2 - Gandalf wins END_TAP my $parser = TAP::Parser::WithBrokenState->new( { tap => $tap } ); my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $parser->next; $parser->next; }; is @die, 1, 'detect broken state machine'; like pop @die, qr/Illegal state: FOO/, '...and the message is as we expect'; } { # coverage testing of TAP::Parser::_iter package TAP::Parser::WithBrokenIter; use base qw( TAP::Parser ); sub _iter {return} package main; my $tap = <<'END_TAP'; 1..2 ok 1 - input file opened ok 2 - Gandalf wins END_TAP my $parser = TAP::Parser::WithBrokenIter->new( { tap => $tap } ); my @die; eval { local $SIG{__WARN__} = sub { }; local $SIG{__DIE__} = sub { push @die, @_ }; $parser->next; }; is @die, 1, 'detect broken iter'; like pop @die, qr/Can't use/, '...and the message is as we expect'; } SKIP: { # http://markmail.org/message/rkxbo6ft7yorgnzb skip "Crashes on older Perls", 2 if $] <= 5.008004 || $] == 5.009; # coverage testing of TAP::Parser::_finish my $tap = <<'END_TAP'; 1..2 ok 1 - input file opened ok 2 - Gandalf wins END_TAP my $parser = TAP::Parser->new( { tap => $tap } ); $parser->tests_run(999); my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; _get_results $parser; }; is @die, 1, 'detect broken test counts'; like pop @die, qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/, '...and the message is as we expect'; } { # Sanity check on state table my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } ); my $state_table = $parser->_make_state_table; my @states = sort keys %$state_table; my @expect = sort qw( bailout comment plan pragma test unknown version yaml ); my %reachable = ( INIT => 1 ); for my $name (@states) { my $state = $state_table->{$name}; my @can_handle = sort keys %$state; is_deeply \@can_handle, \@expect, "token types handled in $name"; for my $type (@can_handle) { $reachable{$_}++ for grep {defined} map { $state->{$type}->{$_} } qw(goto continue); } } is_deeply [ sort keys %reachable ], [@states], "all states reachable"; } { # exit, wait, ignore_exit interactions my @truth = ( [ 0, 0, 0, 0 ], [ 0, 0, 1, 0 ], [ 1, 0, 0, 1 ], [ 1, 0, 1, 0 ], [ 1, 1, 0, 1 ], [ 1, 1, 1, 0 ], [ 0, 1, 0, 1 ], [ 0, 1, 1, 0 ], ); for my $t (@truth) { my ( $wait, $exit, $ignore_exit, $has_problems ) = @$t; my $test_parser = sub { my $parser = shift; $parser->wait($wait); $parser->exit($exit); ok $has_problems ? $parser->has_problems : !$parser->has_problems, "exit=$exit, wait=$wait, ignore=$ignore_exit"; }; my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } ); $parser->ignore_exit($ignore_exit); $test_parser->($parser); $test_parser->( TAP::Parser->new( { tap => "1..1\nok 1\n", ignore_exit => $ignore_exit } ) ); } } Test-Harness-3.36/t/base.t0000644000175000017500000001126712426525633014022 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 38; use TAP::Base; { # No callbacks allowed can_ok 'TAP::Base', 'new'; my $base = TAP::Base->new(); isa_ok $base, 'TAP::Base', 'object of correct type'; for my $method (qw(callback _croak _callback_for _initialize)) { can_ok $base, $method; } eval { $base->callback( some_event => sub { # do nothing } ); }; like( $@, qr/No callbacks/, 'no callbacks allowed croaks OK' ); my $cb = $base->_callback_for('some_event'); ok( !$cb, 'no callback installed' ); } { # No callbacks allowed, constructor should croak eval { my $base = TAP::Base->new( { callbacks => { some_event => sub { # do nothing } } } ); }; like( $@, qr/No callbacks/, 'no callbacks in constructor croaks OK' ); } package CallbackOK; use TAP::Base; use base 'TAP::Base'; sub _initialize { my $self = shift; my $args = shift; $self->SUPER::_initialize( $args, [qw( nice_event other_event )] ); return $self; } package main; { my $base = CallbackOK->new(); isa_ok $base, 'TAP::Base'; eval { $base->callback( some_event => sub { # do nothing } ); }; like( $@, qr/Callback some_event/, 'illegal callback croaks OK' ); my ( $nice, $other ) = ( 0, 0 ); eval { $base->callback( other_event => sub { $other-- } ); $base->callback( nice_event => sub { $nice++; return shift() . 'OK' } ); }; ok( !$@, 'callbacks installed OK' ); my $nice_cbs = $base->_callback_for('nice_event'); is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' ); is( scalar @$nice_cbs, 1, 'right number of callbacks' ); my $nice_cb = $nice_cbs->[0]; ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' ); my $got = $nice_cb->('Is '); is( $got, 'Is OK', 'args passed to callback' ); cmp_ok( $nice, '==', 1, 'callback calls the right sub' ); my $other_cbs = $base->_callback_for('other_event'); is( ref $other_cbs, 'ARRAY', 'callbacks type ok' ); is( scalar @$other_cbs, 1, 'right number of callbacks' ); my $other_cb = $other_cbs->[0]; ok( ref $other_cb eq 'CODE', 'callback for other_event returned' ); $other_cb->(); cmp_ok( $other, '==', -1, 'callback calls the right sub' ); my @got = $base->_make_callback( 'nice_event', 'I am ' ); is( scalar @got, 1, 'right number of results' ); is( $got[0], 'I am OK', 'callback via _make_callback works' ); } { my ( $nice, $other ) = ( 0, 0 ); my $base = CallbackOK->new( { callbacks => { nice_event => sub { $nice++ } } } ); isa_ok $base, 'TAP::Base', 'object creation with callback succeeds'; eval { $base->callback( some_event => sub { # do nothing } ); }; like( $@, qr/Callback some_event/, 'illegal callback croaks OK' ); eval { $base->callback( other_event => sub { $other-- } ); }; ok( !$@, 'callback installed OK' ); my $nice_cbs = $base->_callback_for('nice_event'); is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' ); is( scalar @$nice_cbs, 1, 'right number of callbacks' ); my $nice_cb = $nice_cbs->[0]; ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' ); $nice_cb->(); cmp_ok( $nice, '==', 1, 'callback calls the right sub' ); my $other_cbs = $base->_callback_for('other_event'); is( ref $other_cbs, 'ARRAY', 'callbacks type ok' ); is( scalar @$other_cbs, 1, 'right number of callbacks' ); my $other_cb = $other_cbs->[0]; ok( ref $other_cb eq 'CODE', 'callback for other_event returned' ); $other_cb->(); cmp_ok( $other, '==', -1, 'callback calls the right sub' ); # my @got = $base->_make_callback( 'nice_event', 'I am ' ); # is ( scalar @got, 1, 'right number of results' ); # is( $got[0], 'I am OK', 'callback via _make_callback works' ); my $status = undef; # Stack another callback $base->callback( other_event => sub { $status = 'OK'; return 'Aye' } ); my $new_cbs = $base->_callback_for('other_event'); is( ref $new_cbs, 'ARRAY', 'callbacks type ok' ); is( scalar @$new_cbs, 2, 'right number of callbacks' ); my $new_cb = $new_cbs->[1]; ok( ref $new_cb eq 'CODE', 'callback for new_event returned' ); my @got = $new_cb->(); is( $status, 'OK', 'new callback called OK' ); } Test-Harness-3.36/t/spool.t0000644000175000017500000000617012426525321014233 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } # test T::H::_open_spool and _close_spool - these are good examples # of the 'Fragile Test' pattern - messing with I/O primitives breaks # nearly everything use strict; use warnings; use Test::More; my $useOrigOpen; my $useOrigClose; # setup replacements for core open and close - breaking these makes everything very fragile BEGIN { $useOrigOpen = $useOrigClose = 1; # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2 *CORE::GLOBAL::open = \&my_open; sub my_open (*@) { if ($useOrigOpen) { if ( defined( $_[0] ) ) { use Symbol qw(); my $handle = Symbol::qualify( $_[0], (caller)[0] ); no strict 'refs'; if ( @_ == 1 ) { return CORE::open($handle); } elsif ( @_ == 2 ) { return CORE::open( $handle, $_[1] ); } else { die "Can't open with more than two args"; } } } else { return; } } *CORE::GLOBAL::close = sub (*) { if ($useOrigClose) { return CORE::close(shift) } else {return} }; } use TAP::Harness; use TAP::Parser; use TAP::Parser::Iterator::Array; plan tests => 4; { # coverage tests for the basically untested T::H::_open_spool my @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 # a cleanup hook END { use File::Path; $useOrigOpen = $useOrigClose = 1; # remove the tree if we made it this far rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) if $ENV{PERL_TEST_HARNESS_DUMP_TAP}; } my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; # use the broken open $useOrigOpen = 0; TAP::Harness->_open_spool( File::Spec->catfile(qw (source_tests harness )) ); # restore universal sanity $useOrigOpen = 1; }; is @die, 1, 'open failed, die as expected'; my $spoolDir = quotemeta( File::Spec->catfile( @spool, qw( source_tests harness ) ) ); like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message'; # now make close fail use Symbol; my $spoolHandle = gensym; my $tap = <<'END_TAP'; 1..1 ok 1 - input file opened END_TAP my $parser = TAP::Parser->new( { spool => $spoolHandle, iterator => TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ) } ); @die = (); eval { local $SIG{__DIE__} = sub { push @die, @_ }; # use the broken CORE::close $useOrigClose = 0; TAP::Harness->_close_spool($parser); $useOrigClose = 1; }; unless ( is @die, 1, 'close failed, die as expected' ) { diag " >>> $_ <<<\n" for @die; } like pop @die, qr/ Error closing TAP spool file[(] /, '...with expected message'; } Test-Harness-3.36/t/state.t0000644000175000017500000001731412426525322014222 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More; use App::Prove::State; use App::Prove::State::Result; sub mn { my $pfx = ''; return map {"$pfx$_"} @_; } my @schedule = ( { options => 'all', get_tests_args => [], expect => [ 't/compat/env.t', 't/compat/failure.t', 't/compat/inc_taint.t', 't/compat/version.t', 't/source_handler.t', 't/yamlish-writer.t', ], }, { options => 'failed', get_tests_args => [], expect => [ 't/compat/inc_taint.t', 't/compat/version.t', ], }, { options => 'passed', get_tests_args => [], expect => [ 't/compat/env.t', 't/compat/failure.t', 't/source_handler.t', 't/yamlish-writer.t', ], }, { options => 'last', get_tests_args => [], expect => [ 't/compat/env.t', 't/compat/failure.t', 't/compat/inc_taint.t', 't/compat/version.t', 't/source_handler.t', ], }, { options => 'todo', get_tests_args => [], expect => [ 't/compat/version.t', 't/compat/failure.t', ], }, { options => 'hot', get_tests_args => [], expect => [ 't/compat/version.t', 't/yamlish-writer.t', 't/compat/env.t', ], }, { options => 'adrian', get_tests_args => [], expect => [ 't/compat/version.t', 't/yamlish-writer.t', 't/compat/env.t', 't/compat/failure.t', 't/compat/inc_taint.t', 't/source_handler.t', ], }, { options => 'failed,passed', get_tests_args => [], expect => [ 't/compat/inc_taint.t', 't/compat/version.t', 't/compat/env.t', 't/compat/failure.t', 't/source_handler.t', 't/yamlish-writer.t', ], }, { options => [ 'failed', 'passed' ], get_tests_args => [], expect => [ 't/compat/inc_taint.t', 't/compat/version.t', 't/compat/env.t', 't/compat/failure.t', 't/source_handler.t', 't/yamlish-writer.t', ], }, { options => 'slow', get_tests_args => [], expect => [ 't/yamlish-writer.t', 't/compat/env.t', 't/compat/inc_taint.t', 't/compat/version.t', 't/compat/failure.t', 't/source_handler.t', ], }, { options => 'fast', get_tests_args => [], expect => [ 't/source_handler.t', 't/compat/failure.t', 't/compat/version.t', 't/compat/inc_taint.t', 't/compat/env.t', 't/yamlish-writer.t', ], }, { options => 'old', get_tests_args => [], expect => [ 't/source_handler.t', 't/compat/inc_taint.t', 't/compat/version.t', 't/yamlish-writer.t', 't/compat/failure.t', 't/compat/env.t', ], }, { options => 'new', get_tests_args => [], expect => [ 't/compat/env.t', 't/compat/failure.t', 't/yamlish-writer.t', 't/compat/version.t', 't/compat/inc_taint.t', 't/source_handler.t', ], }, { options => 'fresh', get_tests_args => [], expect => [ 't/compat/env.t', 't/compat/failure.t', ], }, ); plan tests => @schedule * 2; for my $test (@schedule) { my $state = App::Prove::State->new; isa_ok $state, 'App::Prove::State'; my $desc = $test->{options}; # Naughty $state->{_} = get_state(); my $options = $test->{options}; $options = [$options] unless 'ARRAY' eq ref $options; $state->apply_switch(@$options); my @got = $state->get_tests( @{ $test->{get_tests_args} } ); my @expect = mn( @{ $test->{expect} } ); unless ( is_deeply \@got, \@expect, "$desc: order OK" ) { use Data::Dumper; diag( Dumper( { got => \@got, want => \@expect } ) ); } } sub get_state { return App::Prove::State::Result->new( { generation => 51, last_run_time => 1196285439, tests => { mn('t/compat/failure.t') => { last_result => 0, last_run_time => 1196371471.57738, last_pass_time => 1196371471.57738, total_passes => 48, seq => 1549, gen => 51, elapsed => 0.1230, last_todo => 1, mtime => 1196285623, }, mn('t/yamlish-writer.t') => { last_result => 0, last_run_time => 1196371480.5761, last_pass_time => 1196371480.5761, last_fail_time => 1196368609, total_passes => 41, seq => 1578, gen => 49, elapsed => 12.2983, last_todo => 0, mtime => 1196285400, }, mn('t/compat/env.t') => { last_result => 0, last_run_time => 1196371471.42967, last_pass_time => 1196371471.42967, last_fail_time => 1196368608, total_passes => 48, seq => 1548, gen => 52, elapsed => 3.1290, last_todo => 0, mtime => 1196285739, }, mn('t/compat/version.t') => { last_result => 2, last_run_time => 1196371472.96476, last_pass_time => 1196371472.96476, last_fail_time => 1196368609, total_passes => 47, seq => 1555, gen => 51, elapsed => 0.2363, last_todo => 4, mtime => 1196285239, }, mn('t/compat/inc_taint.t') => { last_result => 3, last_run_time => 1196371471.89682, last_pass_time => 1196371471.89682, total_passes => 47, seq => 1551, gen => 51, elapsed => 1.6938, last_todo => 0, mtime => 1196185639, }, mn('t/source_handler.t') => { last_result => 0, last_run_time => 1196371479.72508, last_pass_time => 1196371479.72508, total_passes => 41, seq => 1570, gen => 51, elapsed => 0.0143, last_todo => 0, mtime => 1186285639, }, } } ); } Test-Harness-3.36/t/compat/0000755000175000017500000000000012640746441014177 5ustar leonleonTest-Harness-3.36/t/compat/failure.t0000644000175000017500000000241512426525633016015 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More tests => 5; use File::Spec; use Test::Harness; { #todo_skip 'Harness compatibility incomplete', 5; #local $TODO = 'Harness compatibility incomplete'; my $died; sub prepare_for_death { $died = 0; return sub { $died = 1 } } my $curdir = File::Spec->curdir; my $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' ); { local $SIG{__DIE__} = prepare_for_death(); eval { _runtests( File::Spec->catfile( $sample_tests, "simple" ) ); }; ok( !$@, "simple lives" ); is( $died, 0, "Death never happened" ); } { local $SIG{__DIE__} = prepare_for_death(); eval { _runtests( File::Spec->catfile( $sample_tests, "too_many" ) ); }; ok( $@, "error OK" ); ok( $@ =~ m[Failed 1/1], "too_many dies" ); is( $died, 1, "Death happened" ); } } sub _runtests { my (@tests) = @_; local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; local $ENV{HARNESS_VERBOSE} = 0; local $ENV{HARNESS_DEBUG} = 0; local $ENV{HARNESS_TIMER} = 0; local $Test::Harness::Verbose = -9; runtests(@tests); } # vim:ts=4:sw=4:et:sta Test-Harness-3.36/t/compat/version.t0000644000175000017500000000043012426525323016042 0ustar leonleon#!/usr/bin/perl -Tw use strict; use warnings; use lib 't/lib'; use Test::More tests => 2; use Test::Harness; my $ver = $ENV{HARNESS_VERSION} or die "HARNESS_VERSION not set"; ok( $ver =~ /^[23].\d\d(_\d\d)?$/, "Version is proper format" ); is( $ver, $Test::Harness::VERSION ); Test-Harness-3.36/t/compat/inc_taint.t0000644000175000017500000000116212426525324016331 0ustar leonleon#!/usr/bin/perl -w BEGIN { use lib 't/lib'; } use strict; use warnings; use Test::More tests => 1; use Dev::Null; use Test::Harness; sub _all_ok { my ($tot) = shift; return $tot->{bad} == 0 && ( $tot->{max} || $tot->{skipped} ) ? 1 : 0; } { local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; local $Test::Harness::Verbose = -9; push @INC, 'examples'; tie *NULL, 'Dev::Null' or die $!; select NULL; my ( $tot, $failed ) = Test::Harness::execute_tests( tests => ['t/sample-tests/inc_taint'] ); select STDOUT; ok( _all_ok($tot), 'tests with taint on preserve @INC' ); } Test-Harness-3.36/t/compat/test-harness-compat.t0000644000175000017500000006465312426525326020302 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; # use lib 't/lib'; use Test::More; use File::Spec; 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'; { # if the harness wants to save the resulting TAP we shouldn't # do it for our internal calls local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; my $PER_LOOP = 4; my $results = { 'descriptive' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 5, 'ok' => 5, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, join( ',', qw( descriptive die die_head_end die_last_minute duplicates head_end head_fail inc_taint junk_before_plan lone_not_bug no_nums no_output schwern sequence_misparse shbang_misparse simple simple_fail skip skip_nomsg skipall skipall_nomsg stdout_stderr taint todo_inline todo_misparse too_many vms_nit ) ) => { 'failed' => { "$TEST_DIR/die" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', 'name' => "$TEST_DIR/die", 'wstat' => '256' }, "$TEST_DIR/die_head_end" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', 'name' => "$TEST_DIR/die_head_end", 'wstat' => '256' }, "$TEST_DIR/die_last_minute" => { 'canon' => '??', 'estat' => 1, 'failed' => 0, 'max' => 4, 'name' => "$TEST_DIR/die_last_minute", 'wstat' => '256' }, "$TEST_DIR/duplicates" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => 10, 'name' => "$TEST_DIR/duplicates", 'wstat' => '' }, "$TEST_DIR/head_fail" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 4, 'name' => "$TEST_DIR/head_fail", 'wstat' => '' }, "$TEST_DIR/inc_taint" => { 'canon' => 1, 'estat' => 1, 'failed' => 1, 'max' => 1, 'name' => "$TEST_DIR/inc_taint", 'wstat' => '256' }, "$TEST_DIR/no_nums" => { 'canon' => 3, 'estat' => '', 'failed' => 1, 'max' => 5, 'name' => "$TEST_DIR/no_nums", 'wstat' => '' }, "$TEST_DIR/no_output" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => '??', 'name' => "$TEST_DIR/no_output", 'wstat' => '' }, "$TEST_DIR/simple_fail" => { 'canon' => '2 5', 'estat' => '', 'failed' => 2, 'max' => 5, 'name' => "$TEST_DIR/simple_fail", 'wstat' => '' }, "$TEST_DIR/todo_misparse" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 1, 'name' => "$TEST_DIR/todo_misparse", 'wstat' => '' }, "$TEST_DIR/too_many" => { 'canon' => '4-7', 'estat' => 4, 'failed' => 4, 'max' => 3, 'name' => "$TEST_DIR/too_many", 'wstat' => '1024' }, "$TEST_DIR/vms_nit" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 2, 'name' => "$TEST_DIR/vms_nit", 'wstat' => '' } }, 'todo' => { "$TEST_DIR/todo_inline" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 2, 'name' => "$TEST_DIR/todo_inline", 'wstat' => '' } }, 'totals' => { 'bad' => 12, 'bonus' => 1, 'files' => 27, 'good' => 15, 'max' => 76, 'ok' => 78, 'skipped' => 2, 'sub_skipped' => 2, 'tests' => 27, 'todo' => 2 } }, 'die' => { 'failed' => { "$TEST_DIR/die" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', 'name' => "$TEST_DIR/die", 'wstat' => '256' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 0, 'ok' => 0, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'die_head_end' => { 'failed' => { "$TEST_DIR/die_head_end" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', 'name' => "$TEST_DIR/die_head_end", 'wstat' => '256' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 0, 'ok' => 4, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'die_last_minute' => { 'failed' => { "$TEST_DIR/die_last_minute" => { 'canon' => '??', 'estat' => 1, 'failed' => 0, 'max' => 4, 'name' => "$TEST_DIR/die_last_minute", 'wstat' => '256' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 4, 'ok' => 4, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'duplicates' => { 'failed' => { "$TEST_DIR/duplicates" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => 10, 'name' => "$TEST_DIR/duplicates", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 10, 'ok' => 11, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'head_end' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 4, 'ok' => 4, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'head_fail' => { 'failed' => { "$TEST_DIR/head_fail" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 4, 'name' => "$TEST_DIR/head_fail", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 4, 'ok' => 3, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'inc_taint' => { 'failed' => { "$TEST_DIR/inc_taint" => { 'canon' => 1, 'estat' => 1, 'failed' => 1, 'max' => 1, 'name' => "$TEST_DIR/inc_taint", 'wstat' => '256' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 1, 'ok' => 0, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'junk_before_plan' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 1, 'ok' => 1, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'lone_not_bug' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 4, 'ok' => 4, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'no_nums' => { 'failed' => { "$TEST_DIR/no_nums" => { 'canon' => 3, 'estat' => '', 'failed' => 1, 'max' => 5, 'name' => "$TEST_DIR/no_nums", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 5, 'ok' => 4, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'no_output' => { 'failed' => { "$TEST_DIR/no_output" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => '??', 'name' => "$TEST_DIR/no_output", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 0, 'ok' => 0, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'schwern' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 1, 'ok' => 1, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'sequence_misparse' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 5, 'ok' => 5, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'shbang_misparse' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 2, 'ok' => 2, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'simple' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 5, 'ok' => 5, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'simple_fail' => { 'failed' => { "$TEST_DIR/simple_fail" => { 'canon' => '2 5', 'estat' => '', 'failed' => 2, 'max' => 5, 'name' => "$TEST_DIR/simple_fail", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 5, 'ok' => 3, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'skip' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 5, 'ok' => 5, 'skipped' => 0, 'sub_skipped' => 1, 'tests' => 1, 'todo' => 0 } }, 'skip_nomsg' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 1, 'ok' => 1, 'skipped' => 0, 'sub_skipped' => 1, 'tests' => 1, 'todo' => 0 } }, 'skipall' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 0, 'ok' => 0, 'skipped' => 1, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'skipall_nomsg' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 0, 'ok' => 0, 'skipped' => 1, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'stdout_stderr' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 4, 'ok' => 4, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'switches' => { 'skip_if' => sub { ( $ENV{PERL5OPT} || '' ) =~ m{(?:^|\s)-[dM]}; }, 'failed' => { "$TEST_DIR/switches" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 1, 'name' => "$TEST_DIR/switches", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 1, 'ok' => 0, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'taint' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 1, 'ok' => 1, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'taint_warn' => { 'failed' => {}, 'todo' => {}, 'totals' => { 'bad' => 0, 'bonus' => 0, 'files' => 1, 'good' => 1, 'max' => 1, 'ok' => 1, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 }, 'require' => 5.008001, }, 'todo_inline' => { 'failed' => {}, 'todo' => { "$TEST_DIR/todo_inline" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 2, 'name' => "$TEST_DIR/todo_inline", 'wstat' => '' } }, 'totals' => { 'bad' => 0, 'bonus' => 1, 'files' => 1, 'good' => 1, 'max' => 3, 'ok' => 3, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 2 } }, 'todo_misparse' => { 'failed' => { "$TEST_DIR/todo_misparse" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 1, 'name' => "$TEST_DIR/todo_misparse", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 1, 'ok' => 0, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'too_many' => { 'failed' => { "$TEST_DIR/too_many" => { 'canon' => '4-7', 'estat' => 4, 'failed' => 4, 'max' => 3, 'name' => "$TEST_DIR/too_many", 'wstat' => '1024' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 3, 'ok' => 7, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } }, 'vms_nit' => { 'failed' => { "$TEST_DIR/vms_nit" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 2, 'name' => "$TEST_DIR/vms_nit", 'wstat' => '' } }, 'todo' => {}, 'totals' => { 'bad' => 1, 'bonus' => 0, 'files' => 1, 'good' => 0, 'max' => 2, 'ok' => 1, 'skipped' => 0, 'sub_skipped' => 0, 'tests' => 1, 'todo' => 0 } } }; my $num_tests = ( keys %$results ) * $PER_LOOP; plan tests => $num_tests; sub local_name { my $name = shift; return File::Spec->catfile( split /\//, $name ); } sub local_result { my $hash = shift; my $new = {}; while ( my ( $file, $want ) = each %$hash ) { if ( exists $want->{name} ) { $want->{name} = local_name( $want->{name} ); } $new->{ local_name($file) } = $want; } return $new; } sub vague_status { my $hash = shift; return $hash unless $^O eq 'VMS'; while ( my ( $file, $want ) = each %$hash ) { for (qw( estat wstat )) { if ( exists $want->{$_} ) { $want->{$_} = $want->{$_} ? 1 : 0; } } } return $hash; } { local $^W = 0; # Silence harness output *TAP::Formatter::Console::_output = sub { # do nothing }; } for my $test_key ( sort keys %$results ) { my $result = $results->{$test_key}; SKIP: { if ( $result->{require} && $] < $result->{require} ) { skip "Test requires Perl $result->{require}, we have $]", 4; } if ( my $skip_if = $result->{skip_if} ) { skip "Test '$test_key' can't run properly in this environment", 4 if $skip_if->(); } my @test_names = split( /,/, $test_key ); my @test_files = map { File::Spec->catfile( $TEST_DIR, $_ ) } @test_names; # For now we supress STDERR because it crufts up /our/ test # results. Should probably capture and analyse it. local ( *OLDERR, *OLDOUT ); open OLDERR, '>&STDERR' or die $!; open OLDOUT, '>&STDOUT' or die $!; my $devnull = File::Spec->devnull; open STDERR, ">$devnull" or die $!; open STDOUT, ">$devnull" or die $!; my ( $tot, $fail, $todo, $harness, $aggregate ) = execute_tests( tests => \@test_files ); open STDERR, '>&OLDERR' or die $!; open STDOUT, '>&OLDOUT' or die $!; my $bench = delete $tot->{bench}; isa_ok $bench, 'Benchmark'; # Localise filenames in failed, todo my $lfailed = vague_status( local_result( $result->{failed} ) ); my $ltodo = vague_status( local_result( $result->{todo} ) ); # use Data::Dumper; # diag Dumper( [ $lfailed, $ltodo ] ); is_deeply $tot, $result->{totals}, "totals match for $test_key"; is_deeply vague_status($fail), $lfailed, "failure summary matches for $test_key"; is_deeply vague_status($todo), $ltodo, "todo summary matches for $test_key"; } } } Test-Harness-3.36/t/compat/nonumbers.t0000644000175000017500000000023012426525327016367 0ustar leonleonif ( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) { print "1..0 # Skip: t/TEST needs numbers\n"; exit; } print < '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; Test-Harness-3.36/t/compat/env_opts.t0000644000175000017500000000277212426525633016231 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 12; use Test::Harness; sub _has_module { my $module = shift; eval "use $module"; return $@ ? 0 : 1; } { # Should add a fake home dir? to test the rc stuff.. local $ENV{HARNESS_OPTIONS} = 'j4:c'; ok my $harness = Test::Harness::_new_harness, 'made harness'; is( $harness->color, 1, "set color correctly" ); is( $harness->jobs, 4, "set jobs correctly" ); } SKIP: { skip 'Can\'t locate object method "color" via package "TAP::Formatter::HTML" (RT 82738)',4; skip "requires TAP::Formatter::HTML", 4 unless _has_module('TAP::Formatter::HTML'); local $ENV{HARNESS_OPTIONS} = 'j4:c:fTAP-Formatter-HTML'; ok my $harness = Test::Harness::_new_harness, 'made harness'; is( $harness->color, 1, "set color correctly" ); is( $harness->jobs, 4, "set jobs correctly" ); is( $harness->formatter_class, "TAP::Formatter::HTML", "correct formatter" ); } SKIP: { skip "requires TAP::Harness::Archive", 5 unless _has_module('TAP::Harness::Archive'); # Test archive local $ENV{HARNESS_OPTIONS} = 'j4:c:a/archive.tgz'; ok my $harness = Test::Harness::_new_harness, 'made harness'; is( $harness->color, 1, "set color correctly" ); is( $harness->jobs, 4, "set jobs correctly" ); isa_ok( $harness, "TAP::Harness::Archive", "correct harness subclass" ); # XXX: this is nasty :( is( $harness->{__archive_file}, "/archive.tgz", "correct archive found" ); } Test-Harness-3.36/t/compat/inc-propagation.t0000644000175000017500000000260712426525633017463 0ustar leonleon#!/usr/bin/perl -w # Test that @INC is propogated from the harness process to the test # process. use strict; use warnings; use lib 't/lib'; use Config; local $ENV{PERL5OPT}; # avoid any user-provided PERL5OPT from contaminating @INC sub has_crazy_patch { my $sentinel = 'blirpzoffle'; local $ENV{PERL5LIB} = $sentinel; my $command = join ' ', map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' ); my $path = `$command`; my @got = ( $path =~ /($sentinel)/g ); return @got > 1; } use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' ) : exists $ENV{HARNESS_PERL_SWITCHES} ? ( skip_all => 'Someone messed with HARNESS_PERL_SWITCHES' ) : ( tests => 2 ) ); use Test::Harness; # Change @INC so we ensure it's preserved. use lib 'wibble'; my $test_template = <<'END'; #!/usr/bin/perl %s use Test::More tests => 1; is $INC[0], "wibble", 'basic order of @INC preserved' or diag "\@INC: @INC"; END open TEST, ">inc_check.t.tmp"; printf TEST $test_template, ''; close TEST; open TEST, ">inc_check_taint.t.tmp"; printf TEST $test_template, '-T'; close TEST; END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; } for my $test ( 'inc_check_taint.t.tmp', 'inc_check.t.tmp' ) { my ( $tot, $failed ) = Test::Harness::execute_tests( tests => [$test] ); is $tot->{bad}, 0; } 1; Test-Harness-3.36/t/compat/env.t0000644000175000017500000000116312426525332015151 0ustar leonleon#!/usr/bin/perl -w # Test that env vars are honoured. use strict; use warnings; use lib 't/lib'; use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 1 ) ); use Test::Harness; # HARNESS_PERL_SWITCHES my $test_template = <<'END'; #!/usr/bin/perl use Test::More tests => 1; is $ENV{HARNESS_PERL_SWITCHES}, '-w'; END open TEST, ">env_check_t.tmp"; print TEST $test_template; close TEST; END { unlink 'env_check_t.tmp'; } { local $ENV{HARNESS_PERL_SWITCHES} = '-w'; my ( $tot, $failed ) = Test::Harness::execute_tests( tests => ['env_check_t.tmp'] ); is $tot->{bad}, 0; } 1; Test-Harness-3.36/t/compat/regression.t0000644000175000017500000000056112426525333016543 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More tests => 1; use Test::Harness; # 28567 my ( @before, @after ); { local @INC; unshift @INC, 'wibble'; @before = Test::Harness::_filtered_inc(); unshift @INC, sub {die}; @after = Test::Harness::_filtered_inc(); } is_deeply \@after, \@before, 'subref removed from @INC'; Test-Harness-3.36/t/compat/switches.t0000644000175000017500000000054512426525334016217 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 4 ) ); use Test::Harness; for my $switch ( '-Ifoo', '-I foo' ) { $Test::Harness::Switches = $switch; ok my $harness = Test::Harness::_new_harness, 'made harness'; is_deeply [ $harness->lib ], ['-Ifoo'], 'got libs'; } Test-Harness-3.36/t/premature-bailout.t0000644000175000017500000000451112426525633016543 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 14; use TAP::Parser; use TAP::Parser::Iterator::Array; sub tap_to_lines { my $string = shift; my @lines = ( $string =~ /.*\n/g ); return \@lines; } my $tap = <<'END_TAP'; 1..4 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure Bail out! We ran out of foobar. not ok 5 END_TAP my $parser = TAP::Parser->new( { iterator => TAP::Parser::Iterator::Array->new( tap_to_lines($tap) ), } ); # results() is sane? # check the test plan my $result = $parser->next(); # TEST ok $result->is_plan, 'We should have a plan'; # a normal, passing test my $test = $parser->next(); # TEST ok $test->is_test, '... and a test'; # junk lines should be preserved my $unknown = $parser->next(); # TEST ok $unknown->is_unknown, '... and an unknown line'; # a failing test, which also happens to have a directive my $failed = $parser->next(); # TEST ok $failed->is_test, '... and another test'; # comments my $comment = $parser->next(); # TEST ok $comment->is_comment, '... and a comment'; # another normal, passing test $test = $parser->next(); # TEST ok $test->is_test, '... and another test'; # a failing test $failed = $parser->next(); # TEST ok $failed->is_test, '... and yet another test'; # ok 5 # skip we have no description # skipped test my $bailout = $parser->next(); # TEST ok $bailout->is_bailout, 'And finally we should have a bailout'; # TEST is $bailout->as_string, 'We ran out of foobar.', '... and as_string() should return the explanation'; # TEST is( $bailout->raw, 'Bail out! We ran out of foobar.', '... and raw() should return the explanation' ); # TEST is( $bailout->explanation, 'We ran out of foobar.', '... and it should have the correct explanation' ); my $more_tap = "1..1\nok 1 - input file opened\n"; my $second_parser = TAP::Parser->new( { iterator => TAP::Parser::Iterator::Array->new( [ split( /\n/, $more_tap ) ] ), } ); $result = $second_parser->next(); # TEST ok $result->is_plan(), "Result is not the leftover line"; $result = $second_parser->next(); # TEST ok $result->is_test(), "Result is a test"; # TEST ok $result->is_ok(), "The event has passed"; Test-Harness-3.36/t/bailout.t0000755000175000017500000000617712426525336014556 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 33; use TAP::Parser; my $tap = <<'END_TAP'; 1..4 ok 1 - input file opened ... this is junk not ok first line of the input valid # todo some data # this is a comment ok 3 - read the rest of the file not ok 4 - this is a real failure Bail out! We ran out of foobar. END_TAP my $parser = TAP::Parser->new( { tap => $tap } ); isa_ok $parser, 'TAP::Parser', '... we should be able to parse bailed out tests'; my @results; while ( my $result = $parser->next ) { push @results => $result; } can_ok $parser, 'passed'; is $parser->passed, 3, '... and we shold have the correct number of passed tests'; is_deeply [ $parser->passed ], [ 1, 2, 3 ], '... and get a list of the passed tests'; can_ok $parser, 'failed'; is $parser->failed, 1, '... and the correct number of failed tests'; is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests'; can_ok $parser, 'actual_passed'; is $parser->actual_passed, 2, '... and we shold have the correct number of actually passed tests'; is_deeply [ $parser->actual_passed ], [ 1, 3 ], '... and get a list of the actually passed tests'; can_ok $parser, 'actual_failed'; is $parser->actual_failed, 2, '... and the correct number of actually failed tests'; is_deeply [ $parser->actual_failed ], [ 2, 4 ], '... or get a list of the actually failed tests'; can_ok $parser, 'todo'; is $parser->todo, 1, '... and we should have the correct number of TODO tests'; is_deeply [ $parser->todo ], [2], '... and get a list of the TODO tests'; ok !$parser->skipped, '... and we should have the correct number of skipped tests'; # check the plan can_ok $parser, 'plan'; is $parser->plan, '1..4', '... and we should have the correct plan'; is $parser->tests_planned, 4, '... and the correct number of tests'; # results() is sane? ok @results, 'The parser should return results'; is scalar @results, 8, '... and there should be one for each line'; # check the test plan my $result = shift @results; ok $result->is_plan, 'We should have a plan'; # a normal, passing test my $test = shift @results; ok $test->is_test, '... and a test'; # junk lines should be preserved my $unknown = shift @results; ok $unknown->is_unknown, '... and an unknown line'; # a failing test, which also happens to have a directive my $failed = shift @results; ok $failed->is_test, '... and another test'; # comments my $comment = shift @results; ok $comment->is_comment, '... and a comment'; # another normal, passing test $test = shift @results; ok $test->is_test, '... and another test'; # a failing test $failed = shift @results; ok $failed->is_test, '... and yet another test'; # ok 5 # skip we have no description # skipped test my $bailout = shift @results; ok $bailout->is_bailout, 'And finally we should have a bailout'; is $bailout->as_string, 'We ran out of foobar.', '... and as_string() should return the explanation'; is $bailout->raw, 'Bail out! We ran out of foobar.', '... and raw() should return the explanation'; is $bailout->explanation, 'We ran out of foobar.', '... and it should have the correct explanation'; Test-Harness-3.36/t/grammar.t0000644000175000017500000002715212640746046014537 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; BEGIN { unshift @INC, 't/lib'; } use Test::More tests => 94; use EmptyParser; use TAP::Parser::Grammar; use TAP::Parser::Iterator::Array; my $GRAMMAR = 'TAP::Parser::Grammar'; # Array based iterator that we can push items in to package IT; sub new { my $class = shift; return bless [], $class; } sub next { my $self = shift; return shift @$self; } sub put { my $self = shift; unshift @$self, @_; } sub handle_unicode { } package main; my $iterator = IT->new; my $parser = EmptyParser->new; can_ok $GRAMMAR, 'new'; 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 # why. We'll still use the instance because that should be forward # compatible. my @V12 = sort qw(bailout comment plan simple_test test version); my @V13 = sort ( @V12, 'pragma', 'yaml' ); can_ok $grammar, 'token_types'; ok my @types = sort( $grammar->token_types ), '... and calling it should succeed (v12)'; is_deeply \@types, \@V12, '... and return the correct token types (v12)'; $grammar->set_version(13); ok @types = sort( $grammar->token_types ), '... and calling it should succeed (v13)'; is_deeply \@types, \@V13, '... and return the correct token types (v13)'; can_ok $grammar, 'syntax_for'; can_ok $grammar, 'handler_for'; my ( %syntax_for, %handler_for ); 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', '... and it should return a regex'; ok $handler_for{$type} = $grammar->handler_for($type), '... and calling handler_for() with a type name should succeed'; cmp_ok ref $handler_for{$type}, 'eq', 'CODE', '... and it should return a code reference'; } # Test the plan. Gotta have a plan. my $plan = '1..1'; like $plan, $syntax_for{'plan'}, 'A basic plan should match its syntax'; my $method = $handler_for{'plan'}; $plan =~ $syntax_for{'plan'}; ok my $plan_token = $grammar->$method($plan), '... and the handler should return a token'; my $expected = { 'explanation' => '', 'directive' => '', 'type' => 'plan', 'tests_planned' => 1, 'raw' => '1..1', 'todo_list' => [], }; is_deeply $plan_token, $expected, '... and it should contain the correct data'; can_ok $grammar, 'tokenize'; $iterator->put($plan); ok my $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, '... and the token should contain the correct data'; # a plan with a skip directive $plan = '1..0 # SKIP why not?'; like $plan, $syntax_for{'plan'}, 'a basic plan should match its syntax'; $plan =~ $syntax_for{'plan'}; ok $plan_token = $grammar->$method($plan), '... and the handler should return a token'; $expected = { 'explanation' => 'why not?', 'directive' => 'SKIP', 'type' => 'plan', 'tests_planned' => 0, 'raw' => '1..0 # SKIP why not?', 'todo_list' => [], }; is_deeply $plan_token, $expected, '... and it should contain the correct data'; $iterator->put($plan); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, '... and the token should contain the correct data'; # implied skip $plan = '1..0'; like $plan, $syntax_for{'plan'}, 'A plan with an implied "skip all" should match its syntax'; $plan =~ $syntax_for{'plan'}; ok $plan_token = $grammar->$method($plan), '... and the handler should return a token'; $expected = { 'explanation' => '', 'directive' => 'SKIP', 'type' => 'plan', 'tests_planned' => 0, 'raw' => '1..0', 'todo_list' => [], }; is_deeply $plan_token, $expected, '... and it should contain the correct data'; $iterator->put($plan); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, '... and the token should contain the correct data'; # bad plan $plan = '1..0 # TODO 3,4,5'; # old syntax. No longer supported unlike $plan, $syntax_for{'plan'}, 'Bad plans should not match the plan syntax'; # Bail out! my $bailout = 'Bail out!'; like $bailout, $syntax_for{'bailout'}, 'Bail out! should match a bailout syntax'; $iterator->put($bailout); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'bailout' => '', 'type' => 'bailout', 'raw' => 'Bail out!' }; is_deeply $token, $expected, '... and the token should contain the correct data'; $bailout = 'Bail out! some explanation'; like $bailout, $syntax_for{'bailout'}, 'Bail out! should match a bailout syntax'; $iterator->put($bailout); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'bailout' => 'some explanation', 'type' => 'bailout', 'raw' => 'Bail out! some explanation' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # test comment my $comment = '# this is a comment'; like $comment, $syntax_for{'comment'}, 'Comments should match the comment syntax'; $iterator->put($comment); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'comment' => 'this is a comment', 'type' => 'comment', 'raw' => '# this is a comment' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # test tests :/ my $test = 'ok 1 this is a test'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; $iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'ok' => 'ok', 'explanation' => '', 'type' => 'test', 'directive' => '', 'description' => 'this is a test', 'test_num' => '1', 'raw' => 'ok 1 this is a test' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # TODO tests $test = 'not ok 2 this is a test # TODO whee!'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; $iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'ok' => 'not ok', 'explanation' => 'whee!', 'type' => 'test', 'directive' => 'TODO', 'description' => 'this is a test', 'test_num' => '2', 'raw' => 'not ok 2 this is a test # TODO whee!' }; is_deeply $token, $expected, '... and the TODO should be parsed'; # false TODO tests # escaping that hash mark ('#') means this should *not* be a TODO test $test = 'ok 22 this is a test \# TODO whee!'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; $iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'ok' => 'ok', 'explanation' => '', 'type' => 'test', 'directive' => '', 'description' => 'this is a test \# TODO whee!', 'test_num' => '22', 'raw' => 'ok 22 this is a test \# TODO whee!' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # pragmas my $pragma = 'pragma +strict'; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; $iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'type' => 'pragma', 'raw' => $pragma, 'pragmas' => ['+strict'], }; is_deeply $token, $expected, '... and the token should contain the correct data'; $pragma = 'pragma +strict,-foo'; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; $iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'type' => 'pragma', 'raw' => $pragma, 'pragmas' => [ '+strict', '-foo' ], }; is_deeply $token, $expected, '... and the token should contain the correct data'; $pragma = 'pragma +strict , -foo '; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; $iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'type' => 'pragma', 'raw' => $pragma, 'pragmas' => [ '+strict', '-foo' ], }; is_deeply $token, $expected, '... and the token should contain the correct data'; # coverage tests # set_version { my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $grammar->set_version('no_such_version'); }; unless ( is @die, 1, 'set_version with bad version' ) { diag " >>> $_ <<<\n" for @die; } like pop @die, qr/^Unsupported syntax version: no_such_version at /, '... and got expected message'; } # tokenize { my $iterator = IT->new; my $parser = EmptyParser->new; my $grammar = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); my $plan = ''; $iterator->put($plan); my $result = $grammar->tokenize(); isa_ok $result, 'TAP::Parser::Result::Unknown'; } # _make_plan_token { my $parser = EmptyParser->new; my $grammar = $GRAMMAR->new( { parser => $parser } ); my $plan = '1..1 # SKIP with explanation'; # trigger warning in _make_plan_token my $method = $handler_for{'plan'}; $plan =~ $syntax_for{'plan'}; # perform regex to populate $1, $2 my @warn; eval { local $SIG{__WARN__} = sub { push @warn, @_ }; $grammar->$method($plan); }; is @warn, 1, 'catch warning on inconsistent plan'; like pop @warn, qr/^Specified SKIP directive in plan but more than 0 tests [(]1\.\.1 # SKIP with explanation[)]/, '... and its what we expect'; } # _make_yaml_token SKIP: { skip 'Test is broken and needs repairs', 2; my $iterator = IT->new; my $parser = EmptyParser->new; my $grammar = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); $grammar->set_version(13); # now this is badly formed YAML that is missing the # leader padding - this is done for coverage testing # the $reader code sub in _make_yaml_token, that is # passed as the yaml consumer to T::P::YAMLish::Reader. # because it isnt valid yaml, the yaml document is # not done, and the _peek in the YAMLish::Reader # code doesnt find the terminating '...' pattern. # but we dont care as this is coverage testing, so # if thats what we have to do to exercise that code, # so be it. my $yaml = [ ' --- ', '- 2', ' ... ', ]; sub iter { my $ar = shift; return sub { return shift @$ar; }; } my $iter = iter($yaml); while ( my $line = $iter->() ) { $iterator->put($line); } # pad == ' ', marker == '--- ' # length $pad == 3 # strip == pad my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $grammar->tokenize; }; is @die, 1, 'checking badly formed yaml for coverage testing'; like pop @die, qr/^Missing '[.][.][.]' at end of YAMLish/, '...and it died like we expect'; } { # coverage testing for TAP::Parser::Iterator::Array my $source = [qw( a b c )]; my $aiter = TAP::Parser::Iterator::Array->new($source); my $first = $aiter->next_raw; is $first, 'a', 'access raw iterator'; is $aiter->exit, undef, '... and note we didnt exhaust the source'; } Test-Harness-3.36/t/nofork.t0000755000175000017500000000306412426525340014400 0ustar leonleon#!/usr/bin/perl -w # check nofork logic on systems which *can* fork() # NOTE maybe a good candidate for xt/author or something. BEGIN { use lib 't/lib'; } use strict; use warnings; use Config; use Test::More ( $Config{d_fork} ? 'no_plan' : ( 'skip_all' => 'your system already has no fork' ) ); use IO::c55Capture; # for util use TAP::Harness; sub backticks { my (@args) = @_; util::stdout_of( sub { system(@args) and die "error $?" } ); } my @libs = map "-I$_", @INC; my @perl = ( $^X, @libs ); my $mod = 'TAP::Parser::Iterator::Process'; { # just check the introspective method to start... my $code = qq(print $mod->_use_open3 ? 1 : 2); { my $ans = backticks( @perl, '-MNoFork', "-M$mod", '-e', $code ); is( $ans, 2, 'says not to fork' ); } { local $ENV{PERL5OPT}; # punt: prevent propogating -MNoFork my $ans = backticks( @perl, "-M$mod", '-e', $code ); is( $ans, 1, 'says to fork' ); } } { # and make sure we can run a test my $capture = IO::c55Capture->new_handle; local *STDERR; my $harness = TAP::Harness->new( { verbosity => -2, switches => [ @libs, "-MNoFork" ], stdout => $capture, } ); $harness->runtests('t/sample-tests/simple'); my @output = tied($$capture)->dump; is pop @output, "Result: PASS\n", 'status OK'; pop @output; # get rid of summary line is( $output[-1], "All tests successful.\n", 'ran with no fork' ); } # vim:ts=4:sw=4:et:sta Test-Harness-3.36/t/iterators.t0000644000175000017500000001326712426525341015122 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More tests => 76; use File::Spec; use TAP::Parser; use TAP::Parser::Iterator::Array; use Config; sub array_ref_from { my $string = shift; my @lines = split /\n/ => $string; return \@lines; } # we slurp __DATA__ and then reset it so we don't have to duplicate our TAP my $offset = tell DATA; my $tap = do { local $/; }; seek DATA, $offset, 0; my $did_setup = 0; my $did_teardown = 0; my $setup = sub { $did_setup++ }; my $teardown = sub { $did_teardown++ }; package NoForkProcess; use base qw( TAP::Parser::Iterator::Process ); sub _use_open3 {return} package main; my @schedule = ( { name => 'Process', subclass => 'TAP::Parser::Iterator::Process', source => { command => [ $^X, File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' ) ], merge => 1, setup => $setup, teardown => $teardown, }, after => sub { is $did_setup, 1, "setup called"; is $did_teardown, 1, "teardown called"; }, need_open3 => 15, }, { name => 'Array', subclass => 'TAP::Parser::Iterator::Array', source => array_ref_from($tap), }, { name => 'Stream', subclass => 'TAP::Parser::Iterator::Stream', source => \*DATA, }, { name => 'Process (Perl -e)', subclass => 'TAP::Parser::Iterator::Process', source => { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] }, }, { name => 'Process (NoFork)', subclass => 'TAP::Parser::Iterator::Process', class => 'NoForkProcess', source => { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] }, }, ); sub _can_open3 { return $Config{d_fork}; } for my $test (@schedule) { SKIP: { my $name = $test->{name}; my $need_open3 = $test->{need_open3}; skip "No open3", $need_open3 if $need_open3 && !_can_open3(); my $subclass = $test->{subclass}; my $source = $test->{source}; my $class = $test->{class}; my $iterator = $class ? $class->new($source) : 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 $iterator, $subclass, '... and the object it returns'; can_ok $iterator, 'exit'; ok !defined $iterator->exit, "$name: ... and it should be undef before we are done ($subclass)"; can_ok $iterator, 'next'; is $iterator->next, 'one', "$name: next() should return the first result"; is $iterator->next, 'two', "$name: next() should return the second result"; is $iterator->next, '', "$name: next() should return the third result"; is $iterator->next, 'three', "$name: next() should return the fourth result"; ok !defined $iterator->next, "$name: next() should return undef after it is empty"; is $iterator->exit, 0, "$name: ... and exit should now return 0 ($subclass)"; is $iterator->wait, 0, "$name: wait should also now return 0 ($subclass)"; if ( my $after = $test->{after} ) { $after->(); } } } { # coverage tests for the ctor my $iterator = make_iterator( IO::Handle->new ); isa_ok $iterator, 'TAP::Parser::Iterator::Stream'; my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; make_iterator( \1 ); # a ref to a scalar }; is @die, 1, 'coverage of error case'; like pop @die, qr/Can't iterate with a SCALAR/, '...and we died as expected'; } { # coverage test for VMS case my $iterator = make_iterator( [ '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' $iterator = make_iterator( [ 'not ', ] ); is $iterator->next, 'not ', '...and we find "not" by itself'; } SKIP: { skip "No open3", 4 unless _can_open3(); # coverage testing for TAP::Parser::Iterator::Process ctor my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; make_iterator( {} ); }; is @die, 1, 'coverage testing for TPI::Process'; like pop @die, qr/Must supply a command to execute/, '...and we died as expected'; my $parser = make_iterator( { command => [ $^X, File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' ) ], merge => 1, } ); is $parser->{err}, '', 'confirm we set err to empty string'; is $parser->{sel}, undef, '...and selector to undef'; # And then we read from the parser to sidestep the Mac OS / open3 # 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 three Test-Harness-3.36/t/unicode.t0000644000175000017500000000736012426525342014532 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More; use TAP::Parser; my @schedule; my %make_test; BEGIN { # TODO: Investigate failure on 5.8.0 plan skip_all => "unicode on Perl <= 5.8.0" unless $] > 5.008; plan skip_all => "PERL_UNICODE set" if defined $ENV{PERL_UNICODE}; eval "use File::Temp"; plan skip_all => "File::Temp unavailable" if $@; eval "use Encode"; plan skip_all => "Encode unavailable" if $@; # Subs that take the supplied TAP and turn it into a set of args to # supply to TAP::Harness->new. The returned hash includes the # temporary file so that its reference count doesn't go to zero # until we're finished with it. %make_test = ( file => sub { my $source = shift; my $tmp = File::Temp->new; open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n"; eval 'binmode( $fh, ":utf8" )'; print $fh join( "\n", @$source ), "\n"; close $fh; open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n"; eval 'binmode( $taph, ":utf8" )'; return { temp => $tmp, args => { source => $taph }, }; }, script => sub { my $source = shift; my $tmp = File::Temp->new; open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n"; eval 'binmode( $fh, ":utf8" )'; print $fh map {"print qq{$_\\n};\n"} @$source; close $fh; open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n"; return { temp => $tmp, args => { exec => [ $^X, "$tmp" ] }, }; }, ); @schedule = ( { name => 'Non-unicode warm up', source => [ 'TAP version 13', '1..1', 'ok 1 Everything is fine', ], expect => [ { isa => 'TAP::Parser::Result::Version', }, { isa => 'TAP::Parser::Result::Plan', }, { isa => 'TAP::Parser::Result::Test', description => "Everything is fine" }, ], }, { name => 'Unicode smiley', source => [ 'TAP version 13', '1..1', # Funky quoting / eval to avoid errors on older Perls eval qq{"ok 1 Everything is fine \\x{263a}"}, ], expect => [ { isa => 'TAP::Parser::Result::Version', }, { isa => 'TAP::Parser::Result::Plan', }, { isa => 'TAP::Parser::Result::Test', description => eval qq{"Everything is fine \\x{263a}"} }, ], } ); plan 'no_plan'; } for my $test (@schedule) { for my $type ( sort keys %make_test ) { my $name = sprintf( "%s (%s)", $test->{name}, $type ); my $args = $make_test{$type}->( $test->{source} ); my $parser = TAP::Parser->new( $args->{args} ); isa_ok $parser, 'TAP::Parser'; my @expect = @{ $test->{expect} }; while ( my $tok = $parser->next ) { my $exp = shift @expect; for my $item ( sort keys %$exp ) { my $val = $exp->{$item}; if ( 'isa' eq $item ) { isa_ok $tok, $val; } elsif ( 'CODE' eq ref $val ) { ok $val->($tok), "$name: assertion for $item"; } else { my $got = $tok->$item(); is $got, $val, "$name: value for $item matches"; } } } } } Test-Harness-3.36/t/glob-to-regexp.t0000644000175000017500000000173412426525342015736 0ustar leonleon#!/usr/bin/perl -w use strict; use warnings; use Test::More; require TAP::Parser::Scheduler; my @tests; while () { my ( $glob, $pattern, $name ) = /^(\S+)\t+(\S+)(?:\t+(.*))?$/; die "'$_'" unless $pattern; push @tests, [ $glob, $pattern, $name ]; } plan tests => scalar @tests; for (@tests) { my ( $glob, $pattern, $name ) = @$_; is( TAP::Parser::Scheduler->_glob_to_regexp($glob), $pattern, defined $name ? "$glob -- $name" : $glob ); } __DATA__ Pie Pie *.t [^/]*\.t **.t .*?\.t A?B A[^/]B */*.t [^/]*\/[^/]*\.t A,B A\,B , outside {} not special {A,B} (?:A|B) A{B}C A(?:B)C A{B,C}D A(?:B|C)D A{B,C,D}E{F,G,H}I,J A(?:B|C|D)E(?:F|G|H)I\,J {Perl,Rules} (?:Perl|Rules) A}B A\}B Bare } corner case A{B,C}D}E A(?:B|C)D\}E },A{B,C}D},E \}\,A(?:B|C)D\}\,E {A{1,2},D{3,4}} (?:A(?:1|2)|D(?:3|4)) {A,{B,C},D} (?:A|(?:B|C)|D) A{B,C\}D,E\,F}G A(?:B|C\}D|E\,F)G A\\B A\\B A(B)C A\(B\)C 1{A(B)C,D|E}2 1(?:A\(B\)C|D\|E)2 Test-Harness-3.36/t/source.t0000755000175000017500000002033012426525344014401 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More tests => 45; use File::Spec; my $dir = 't/source_tests'; use_ok('TAP::Parser::Source'); sub ct($) { my $hash = shift; if ( $ENV{PERL_CORE} ) { delete $hash->{is_symlink}; delete $hash->{lstat}; } return $hash; } # 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' ); $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( ct $meta, ct {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( ct $file, ct {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, # Fix for bizarre -k bug in Strawberry Perl sticky => ( -k $test )[-1] ? 1 : 0, setgid => -g $test ? 1 : 0, setuid => -u $test ? 1 : 0, }, '... file->* set' ); } # dir test { my $test = $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( ct $meta, ct {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( ct $file, ct {basename => 'source_tests', ext => '', lc_ext => '', text => 0, exists => 1, is_dir => 1, is_file => 0, is_symlink => 0, sticky => ( -k $test )[-1] ? 1 : 0, setgid => -g $test ? 1 : 0, setuid => -u $test ? 1 : 0, }, '... file->* set' ); } # symlink test SKIP: { my $symlink_exists = eval { symlink( '', '' ); 1 }; $symlink_exists = 0 if $^O eq 'VMS'; # exists but not ready for prime time skip 'symlink not supported on this platform', 9 unless $symlink_exists; my $test = File::Spec->catfile( $dir, 'source.t' ); my $symlink = File::Spec->catfile( $dir, 'source_link.T' ); my $source = TAP::Parser::Source->new; eval { symlink( File::Spec->rel2abs($test), $symlink ) }; if ( my $e = $@ ) { diag($@); die "aborting test"; } $source->raw( \$symlink ); my $meta = $source->assemble_meta; # separate meta->file to break up the test my $file = delete $meta->{file}; is_deeply( ct $meta, ct {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' ); # 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( ct $file, ct {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 => ( -k $symlink )[-1] ? 1 : 0, setgid => -g $symlink ? 1 : 0, setuid => -u $symlink ? 1 : 0, }, '... file->* set' ); unlink $symlink; } Test-Harness-3.36/t/proverc.t0000644000175000017500000000073012426525345014561 0ustar leonleon#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use lib 't/lib'; use Test::More tests => 1; use File::Spec; use App::Prove; my $prove = App::Prove->new; $prove->add_rc_file( File::Spec->catfile( 't', 'data', 'proverc' ) ); is_deeply $prove->{rc_opts}, [ '--should', 'be', '--split', 'correctly', 'Can', 'quote things', 'using single or', 'double quotes', '--this', 'is', 'OK?' ], 'options parsed'; Test-Harness-3.36/t/console.t0000644000175000017500000000207312426525345014545 0ustar leonleonuse strict; use warnings; use lib 't/lib'; use Test::More; use TAP::Formatter::Console; my @schedule; BEGIN { @schedule = ( { method => '_range', in => sub {qw/2 7 1 3 10 9/}, out => sub {qw/1-3 7 9-10/}, name => '... and it should return numbers as ranges' }, { method => '_balanced_range', in => sub { 7, qw/2 7 1 3 10 9/ }, out => sub { '1-3, 7', '9-10' }, name => '... and it should return numbers as ranges' }, ); plan tests => @schedule * 3; } for my $test (@schedule) { my $name = $test->{name}; my $cons = TAP::Formatter::Console->new; isa_ok $cons, 'TAP::Formatter::Console'; my $method = $test->{method}; can_ok $cons, $method; is_deeply [ $cons->$method( $test->{in}->() ) ], [ $test->{out}->() ], $name; } #### Color tests #### package Colorizer; sub new { bless {}, shift } sub can_color {1} sub set_color { my ( $self, $output, $color ) = @_; $output->("[[$color]]"); } package main; Test-Harness-3.36/t/errors.t0000644000175000017500000001122312426525346014415 0ustar leonleon#!/usr/bin/perl -wT use strict; use warnings; use lib 't/lib'; use Test::More tests => 23; use TAP::Parser; my $plan_line = 'TAP::Parser::Result::Plan'; my $test_line = 'TAP::Parser::Result::Test'; sub _parser { my $parser = TAP::Parser->new( { tap => shift } ); $parser->run; return $parser; } # validate that plan! my $parser = _parser(<<'END_TAP'); ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 - read the rest of the file 1..3 # comments are allowed after an ending plan END_TAP can_ok $parser, 'parse_errors'; ok !$parser->parse_errors, '... comments should be allowed after a terminating plan'; $parser = _parser(<<'END_TAP'); ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 - read the rest of the file 1..3 # yeah, yeah, I know. ok END_TAP can_ok $parser, 'parse_errors'; is scalar $parser->parse_errors, 2, '... and we should have two parse errors'; is [ $parser->parse_errors ]->[0], 'Plan (1..3) must be at the beginning or end of the TAP output', '... telling us that our plan was misplaced'; is [ $parser->parse_errors ]->[1], 'Bad plan. You planned 3 tests but ran 4.', '... and telling us we ran the wrong number of tests.'; $parser = _parser(<<'END_TAP'); ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 - read the rest of the file #1..3 # yo quiero tests! 1..3 END_TAP ok !$parser->parse_errors, '... but test plan-like data can be in a comment'; $parser = _parser(<<'END_TAP'); ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 - read the rest of the file 1..5 # yo quiero tests! 1..3 END_TAP ok !$parser->parse_errors, '... or a description'; $parser = _parser(<<'END_TAP'); ok 1 - input file opened not ok 2 - first line of the input valid # todo 1..4 ok 3 - read the rest of the file # yo quiero tests! 1..3 END_TAP ok !$parser->parse_errors, '... or a directive'; # test numbers included? $parser = _parser(<<'END_TAP'); 1..3 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok read the rest of the file # this is ... END_TAP eval { $parser->run }; ok !$@, 'We can mix and match the presence of test numbers'; $parser = _parser(<<'END_TAP'); 1..3 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 2 read the rest of the file END_TAP is + ( $parser->parse_errors )[0], 'Tests out of sequence. Found (2) but expected (3)', '... and if the numbers are there, they cannot be out of sequence'; $parser = _parser(<<'END_TAP'); ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 2 read the rest of the file END_TAP is $parser->parse_errors, 2, 'Having two errors in the TAP should result in two errors (duh)'; my $expected = [ 'Tests out of sequence. Found (2) but expected (3)', 'No plan found in TAP output' ]; is_deeply [ $parser->parse_errors ], $expected, '... and they should be the correct errors'; $parser = _parser(<<'END_TAP'); ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 read the rest of the file END_TAP is $parser->parse_errors, 1, 'Having no plan should cause an error'; is + ( $parser->parse_errors )[0], 'No plan found in TAP output', '... with a correct error message'; $parser = _parser(<<'END_TAP'); 1..3 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 read the rest of the file 1..3 END_TAP is $parser->parse_errors, 1, 'Having more than one plan should cause an error'; is + ( $parser->parse_errors )[0], 'More than one plan found in TAP output', '... with a correct error message'; can_ok $parser, 'is_good_plan'; $parser = _parser(<<'END_TAP'); 1..2 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 read the rest of the file END_TAP is $parser->parse_errors, 1, 'Having the wrong number of planned tests is a parse error'; is + ( $parser->parse_errors )[0], 'Bad plan. You planned 2 tests but ran 3.', '... with a correct error message'; # XXX internals: plan will not set to true if defined $parser->is_good_plan(undef); $parser = _parser(<<'END_TAP'); ok 1 - input file opened 1..1 END_TAP ok $parser->is_good_plan, '... and it should return true if the plan is correct'; # TAP::Parser coverage tests { # good_plan coverage my @warn; eval { local $SIG{__WARN__} = sub { push @warn, @_ }; $parser->good_plan; }; is @warn, 1, 'coverage testing of good_plan'; like pop @warn, qr/good_plan[(][)] is deprecated. Please use "is_good_plan[(][)]"/, '...and it fell-back like we expected'; } Test-Harness-3.36/lib/0000755000175000017500000000000012640746441013217 5ustar leonleonTest-Harness-3.36/lib/Test/0000755000175000017500000000000012640746441014136 5ustar leonleonTest-Harness-3.36/lib/Test/Harness.pm0000644000175000017500000004014712640746046016106 0ustar leonleonpackage Test::Harness; use 5.006; use strict; use warnings; 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 (); use TAP::Parser::SourceHandler::Perl (); use Text::ParseWords qw(shellwords); use Config; use base 'Exporter'; # $ML $Last_ML_Print BEGIN { eval q{use Time::HiRes 'time'}; our $has_time_hires = !$@; } =head1 NAME Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; *switches = *Switches; *debug = *Debug; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; END { # For VMS. delete $ENV{HARNESS_ACTIVE}; delete $ENV{HARNESS_VERSION}; } our @EXPORT = qw(&runtests); our @EXPORT_OK = qw(&execute_tests $verbose $switches); our $Verbose = $ENV{HARNESS_VERBOSE} || 0; our $Debug = $ENV{HARNESS_DEBUG} || 0; our $Switches = '-w'; our $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; $Columns--; # Some shells have trouble with a full line of text. our $Timer = $ENV{HARNESS_TIMER} || 0; our $Color = $ENV{HARNESS_COLOR} || 0; our $IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0; =head1 SYNOPSIS use Test::Harness; runtests(@test_files); =head1 DESCRIPTION Although, for historical reasons, the L distribution takes its name from this module it now exists only to provide L with an interface that is somewhat backwards compatible with L 2.xx. If you're writing new code consider using L directly instead. Emulation is provided for C and C but the pluggable 'Straps' interface that previous versions of L supported is not reproduced here. Straps is now available as a stand alone module: L. See L, L for the main documentation for this distribution. =head1 FUNCTIONS The following functions are available. =head2 runtests( @test_files ) This runs all the given I<@test_files> and divines whether they passed or failed based on their output to STDOUT (details above). It prints out each individual test which failed along with a summary report and a how long it all took. It returns true if everything was ok. Otherwise it will C with one of the messages in the DIAGNOSTICS section. =cut sub _has_taint { my $test = shift; return TAP::Parser::SourceHandler::Perl->get_taint( TAP::Parser::Source->shebang($test) ); } sub _aggregate { my ( $harness, $aggregate, @tests ) = @_; # Don't propagate to our children local $ENV{HARNESS_OPTIONS}; _apply_extra_INC($harness); _aggregate_tests( $harness, $aggregate, @tests ); } # Make sure the child sees all the extra junk in @INC sub _apply_extra_INC { my $harness = shift; $harness->callback( parser_args => sub { my ( $args, $test ) = @_; push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); } ); } sub _aggregate_tests { my ( $harness, $aggregate, @tests ) = @_; $aggregate->start(); $harness->aggregate_tests( $aggregate, @tests ); $aggregate->stop(); } sub runtests { my @tests = @_; # shield against -l local ( $\, $, ); my $harness = _new_harness(); my $aggregate = TAP::Parser::Aggregator->new(); _aggregate( $harness, $aggregate, @tests ); $harness->formatter->summary($aggregate); my $total = $aggregate->total; my $passed = $aggregate->passed; my $failed = $aggregate->failed; my @parsers = $aggregate->parsers; my $num_bad = 0; for my $parser (@parsers) { $num_bad++ if $parser->has_problems; } die(sprintf( "Failed %d/%d test programs. %d/%d subtests failed.\n", $num_bad, scalar @parsers, $failed, $total ) ) if $num_bad; return $total && $total == $passed; } sub _canon { my @list = sort { $a <=> $b } @_; my @ranges = (); my $count = scalar @list; my $pos = 0; while ( $pos < $count ) { my $end = $pos + 1; $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1; push @ranges, ( $end == $pos + 1 ) ? $list[$pos] : join( '-', $list[$pos], $list[ $end - 1 ] ); $pos = $end; } return join( ' ', @ranges ); } sub _new_harness { my $sub_args = shift || {}; my ( @lib, @switches ); my @opt = map { shellwords($_) } grep { defined } $Switches, $ENV{HARNESS_PERL_SWITCHES}; while ( my $opt = shift @opt ) { if ( $opt =~ /^ -I (.*) $ /x ) { push @lib, length($1) ? $1 : shift @opt; } else { push @switches, $opt; } } # Do things the old way on VMS... push @lib, _filtered_inc() if IS_VMS; # If $Verbose isn't numeric default to 1. This helps core. my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 ); my $args = { timer => $Timer, directives => our $Directives, lib => \@lib, switches => \@switches, color => $Color, verbosity => $verbosity, ignore_exit => $IgnoreExit, }; $args->{stdout} = $sub_args->{out} if exists $sub_args->{out}; my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { for my $opt ( split /:/, $env_opt ) { if ( $opt =~ /^j(\d*)$/ ) { $args->{jobs} = $1 || 9; } elsif ( $opt eq 'c' ) { $args->{color} = 1; } elsif ( $opt =~ m/^f(.*)$/ ) { my $fmt = $1; $fmt =~ s/-/::/g; $args->{formatter_class} = $fmt; } elsif ( $opt =~ m/^a(.*)$/ ) { my $archive = $1; $class = "TAP::Harness::Archive"; $args->{archive} = $archive; } else { die "Unknown HARNESS_OPTIONS item: $opt\n"; } } } return TAP::Harness->_construct( $class, $args ); } # Get the parts of @INC which are changed from the stock list AND # preserve reordering of stock directories. sub _filtered_inc { my @inc = grep { !ref } @INC; #28567 if (IS_VMS) { # VMS has a 255-byte limit on the length of %ENV entries, so # toss the ones that involve perl_root, the install location @inc = grep !/perl_root/i, @inc; } elsif (IS_WIN32) { # Lose any trailing backslashes in the Win32 paths s/[\\\/]+$// for @inc; } my @default_inc = _default_inc(); my @new_inc; my %seen; for my $dir (@inc) { next if $seen{$dir}++; if ( $dir eq ( $default_inc[0] || '' ) ) { shift @default_inc; } else { push @new_inc, $dir; } shift @default_inc while @default_inc and $seen{ $default_inc[0] }; } return @new_inc; } { # Cache this to avoid repeatedly shelling out to Perl. my @inc; sub _default_inc { return @inc if @inc; local $ENV{PERL5LIB}; local $ENV{PERLLIB}; 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[]"` ); return @inc; } } sub _check_sequence { my @list = @_; my $prev; while ( my $next = shift @list ) { return if defined $prev && $next <= $prev; $prev = $next; } return 1; } sub execute_tests { my %args = @_; my $harness = _new_harness( \%args ); my $aggregate = TAP::Parser::Aggregator->new(); my %tot = ( bonus => 0, max => 0, ok => 0, bad => 0, good => 0, files => 0, tests => 0, sub_skipped => 0, todo => 0, skipped => 0, bench => undef, ); # Install a callback so we get to see any plans the # harness executes. $harness->callback( made_parser => sub { my $parser = shift; $parser->callback( plan => sub { my $plan = shift; if ( $plan->directive eq 'SKIP' ) { $tot{skipped}++; } } ); } ); _aggregate( $harness, $aggregate, @{ $args{tests} } ); $tot{bench} = $aggregate->elapsed; my @tests = $aggregate->descriptions; # TODO: Work out the circumstances under which the files # and tests totals can differ. $tot{files} = $tot{tests} = scalar @tests; my %failedtests = (); my %todo_passed = (); for my $test (@tests) { my ($parser) = $aggregate->parsers($test); my @failed = $parser->failed; my $wstat = $parser->wait; my $estat = $parser->exit; my $planned = $parser->tests_planned; my @errors = $parser->parse_errors; my $passed = $parser->passed; my $actual_passed = $parser->actual_passed; my $ok_seq = _check_sequence( $parser->actual_passed ); # Duplicate exit, wait status semantics of old version $estat ||= '' unless $wstat; $wstat ||= ''; $tot{max} += ( $planned || 0 ); $tot{bonus} += $parser->todo_passed; $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed; $tot{sub_skipped} += $parser->skipped; $tot{todo} += $parser->todo; if ( @failed || $estat || @errors ) { $tot{bad}++; my $huh_planned = $planned ? undef : '??'; my $huh_errors = $ok_seq ? undef : '??'; $failedtests{$test} = { 'canon' => $huh_planned || $huh_errors || _canon(@failed) || '??', 'estat' => $estat, 'failed' => $huh_planned || $huh_errors || scalar @failed, 'max' => $huh_planned || $planned, 'name' => $test, 'wstat' => $wstat }; } else { $tot{good}++; } my @todo = $parser->todo_passed; if (@todo) { $todo_passed{$test} = { 'canon' => _canon(@todo), 'estat' => $estat, 'failed' => scalar @todo, 'max' => scalar $parser->todo, 'name' => $test, 'wstat' => $wstat }; } } return ( \%tot, \%failedtests, \%todo_passed ); } =head2 execute_tests( tests => \@test_files, out => \*FH ) Runs all the given C<@test_files> (just like C) but doesn't generate the final report. During testing, progress information will be written to the currently selected output filehandle (usually C), or to the filehandle given by the C parameter. The I is optional. Returns a list of two values, C<$total> and C<$failed>, describing the results. C<$total> is a hash ref summary of all the tests run. Its keys and values are this: bonus Number of individual todo tests unexpectedly passed max Number of individual tests ran ok Number of individual tests passed sub_skipped Number of individual tests skipped todo Number of individual todo tests files Number of test files ran good Number of test files passed bad Number of test files failed tests Number of test files originally given skipped Number of test files skipped If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've got a successful test. C<$failed> is a hash ref of all the test scripts that failed. Each key is the name of a test script, each value is another hash representing how that script failed. Its keys are these: name Name of the test which failed estat Script's exit value wstat Script's wait status max Number of individual tests failed Number which failed canon List of tests which failed (as string). C<$failed> should be empty if everything passed. =cut 1; __END__ =head1 EXPORT C<&runtests> is exported by C by default. C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are exported upon request. =head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS C sets these before executing the individual tests. =over 4 =item C This is set to a true value. It allows the tests to determine if they are being executed through the harness or by any other means. =item C This is the version of C. =back =head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS =over 4 =item C Setting this adds perl command line switches to each test file run. For example, C will turn on taint mode. C will run C for each test. C<-w> is always set. You can turn this off in the test with C. =item C Setting this to true will make the harness display the number of milliseconds each test took. You can also use F's C<--timer> switch. =item C If true, C will output the verbose results of running its tests. Setting C<$Test::Harness::verbose> will override this, or you can use the C<-v> switch in the F utility. =item C Provide additional options to the harness. Currently supported options are: =over =item C<< j >> Run (default 9) parallel jobs. =item C<< c >> Try to color output. See L. =item C<< a >> Will use L as the harness class, and save the TAP to C =item C<< fPackage-With-Dashes >> Set the formatter_class of the harness being run. Since the C is seperated by C<:>, we use C<-> instead. =back Multiple options may be separated by colons: HARNESS_OPTIONS=j9:c make test =item C Specifies a TAP::Harness subclass to be used in place of TAP::Harness. =item C Determines the L for the summary in case it is successful. This color defaults to C<'green'>. =item C Determines the L for the failure in case it is successful. This color defaults to C<'red'>. =back =head1 Taint Mode Normally when a Perl program is run in taint mode the contents of the C environment variable do not appear in C<@INC>. Because C is often used during testing to add build directories to C<@INC> C passes the names of any directories found in C as -I switches. The net effect of this is that C is honoured even in taint mode. =head1 SEE ALSO L =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 AUTHORS Andy Armstrong C<< >> L 2.64 (maintained by Andy Lester and on which this module is based) has this attribution: Either Tim Bunce or Andreas Koenig, we don't know. What we know for sure is, that it was inspired by Larry Wall's F script that came with perl distributions for ages. Numerous anonymous contributors exist. Andreas Koenig held the torch for many years, and then Michael G Schwern. =head1 LICENCE AND COPYRIGHT Copyright (c) 2007-2011, Andy Armstrong C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. Test-Harness-3.36/lib/App/0000755000175000017500000000000012640746441013737 5ustar leonleonTest-Harness-3.36/lib/App/Prove.pm0000644000175000017500000004474512640746046015407 0ustar leonleonpackage App::Prove; use strict; use warnings; use TAP::Harness::Env; use Text::ParseWords qw(shellwords); use File::Spec; use Getopt::Long; use App::Prove::State; use Carp; use base 'TAP::Object'; =head1 NAME App::Prove - Implements the C command. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION L provides a command, C, which runs a TAP based test suite and prints a report. The C command is a minimal wrapper around an instance of this module. =head1 SYNOPSIS use App::Prove; my $app = App::Prove->new; $app->process_args(@ARGV); $app->run; =cut use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant IS_VMS => $^O eq 'VMS'; use constant IS_UNIXY => !( IS_VMS || IS_WIN32 ); use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove'; use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc'; use constant PLUGINS => 'App::Prove::Plugin'; my @ATTR; BEGIN { @ATTR = qw( archive argv blib show_count color directives exec failures comments formatter harness includes modules plugins jobs lib merge parse quiet really_quiet recurse backwards shuffle taint_fail taint_warn timer verbose warnings_fail warnings_warn show_help show_man show_version state_class test_args state dry extensions ignore_exit rules state_manager normalize sources tapversion trap ); __PACKAGE__->mk_methods(@ATTR); } =head1 METHODS =head2 Class Methods =head3 C Create a new C. Optionally a hash ref of attribute initializers may be passed. =cut # new() implementation supplied by TAP::Object sub _initialize { my $self = shift; my $args = shift || {}; my @is_array = qw( argv rc_opts includes modules state plugins rules sources ); # setup defaults: for my $key (@is_array) { $self->{$key} = []; } for my $attr (@ATTR) { if ( exists $args->{$attr} ) { # TODO: Some validation here $self->{$attr} = $args->{$attr}; } } $self->state_class('App::Prove::State'); return $self; } =head3 C Getter/setter for the name of the class used for maintaining state. This class should either subclass from C or provide an identical interface. =head3 C Getter/setter for the instance of the C. =cut =head3 C $prove->add_rc_file('myproj/.proverc'); Called before C to prepend the contents of an rc file to the options. =cut sub add_rc_file { my ( $self, $rc_file ) = @_; local *RC; open RC, "<$rc_file" or croak "Can't read $rc_file ($!)"; while ( defined( my $line = ) ) { push @{ $self->{rc_opts} }, grep { defined and not /^#/ } $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg; } close RC; } =head3 C $prove->process_args(@args); Processes the command-line arguments. Attributes will be set appropriately. Any filenames may be found in the C attribute. Dies on invalid arguments. =cut sub process_args { my $self = shift; my @rc = RC_FILE; unshift @rc, glob '~/' . RC_FILE if IS_UNIXY; # Preprocess meta-args. my @args; while ( defined( my $arg = shift ) ) { if ( $arg eq '--norc' ) { @rc = (); } elsif ( $arg eq '--rc' ) { defined( my $rc = shift ) or croak "Missing argument to --rc"; push @rc, $rc; } elsif ( $arg =~ m{^--rc=(.+)$} ) { push @rc, $1; } else { push @args, $arg; } } # Everything after the arisdottle '::' gets passed as args to # test programs. if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) { my @test_args = splice @args, $stop_at; shift @test_args; $self->{test_args} = \@test_args; } # Grab options from RC files $self->add_rc_file($_) for grep -f, @rc; unshift @args, @{ $self->{rc_opts} }; if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) { die "Long options should be written with two dashes: ", join( ', ', @bad ), "\n"; } # And finally... { local @ARGV = @args; Getopt::Long::Configure(qw(no_ignore_case bundling pass_through)); # Don't add coderefs to GetOptions GetOptions( 'v|verbose' => \$self->{verbose}, 'f|failures' => \$self->{failures}, 'o|comments' => \$self->{comments}, 'l|lib' => \$self->{lib}, 'b|blib' => \$self->{blib}, 's|shuffle' => \$self->{shuffle}, 'color!' => \$self->{color}, 'colour!' => \$self->{color}, 'count!' => \$self->{show_count}, 'c' => \$self->{color}, 'D|dry' => \$self->{dry}, 'ext=s@' => sub { my ( $opt, $val ) = @_; # Workaround for Getopt::Long 2.25 handling of # multivalue options push @{ $self->{extensions} ||= [] }, $val; }, 'harness=s' => \$self->{harness}, 'ignore-exit' => \$self->{ignore_exit}, 'source=s@' => $self->{sources}, 'formatter=s' => \$self->{formatter}, 'r|recurse' => \$self->{recurse}, 'reverse' => \$self->{backwards}, 'p|parse' => \$self->{parse}, 'q|quiet' => \$self->{quiet}, 'Q|QUIET' => \$self->{really_quiet}, 'e|exec=s' => \$self->{exec}, 'm|merge' => \$self->{merge}, 'I=s@' => $self->{includes}, 'M=s@' => $self->{modules}, 'P=s@' => $self->{plugins}, 'state=s@' => $self->{state}, 'directives' => \$self->{directives}, 'h|help|?' => \$self->{show_help}, 'H|man' => \$self->{show_man}, 'V|version' => \$self->{show_version}, 'a|archive=s' => \$self->{archive}, 'j|jobs=i' => \$self->{jobs}, 'timer' => \$self->{timer}, 'T' => \$self->{taint_fail}, 't' => \$self->{taint_warn}, 'W' => \$self->{warnings_fail}, 'w' => \$self->{warnings_warn}, 'normalize' => \$self->{normalize}, 'rules=s@' => $self->{rules}, 'tapversion=s' => \$self->{tapversion}, 'trap' => \$self->{trap}, ) or croak('Unable to continue'); # Stash the remainder of argv for later $self->{argv} = [@ARGV]; } return; } sub _first_pos { my $want = shift; for ( 0 .. $#_ ) { return $_ if $_[$_] eq $want; } return; } sub _help { my ( $self, $verbosity ) = @_; eval('use Pod::Usage 1.12 ()'); if ( my $err = $@ ) { die 'Please install Pod::Usage for the --help option ' . '(or try `perldoc prove`.)' . "\n ($@)"; } Pod::Usage::pod2usage( { -verbose => $verbosity } ); return; } sub _color_default { my $self = shift; return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32; } sub _get_args { my $self = shift; my %args; $args{trap} = 1 if $self->trap; if ( defined $self->color ? $self->color : $self->_color_default ) { $args{color} = 1; } if ( !defined $self->show_count ) { $args{show_count} = 1; } else { $args{show_count} = $self->show_count; } if ( $self->archive ) { $self->require_harness( archive => 'TAP::Harness::Archive' ); $args{archive} = $self->archive; } if ( my $jobs = $self->jobs ) { $args{jobs} = $jobs; } if ( my $harness_opt = $self->harness ) { $self->require_harness( harness => $harness_opt ); } if ( my $formatter = $self->formatter ) { $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; } if ( $self->taint_fail && $self->taint_warn ) { die '-t and -T are mutually exclusive'; } if ( $self->warnings_fail && $self->warnings_warn ) { die '-w and -W are mutually exclusive'; } for my $a (qw( lib switches )) { my $method = "_get_$a"; my $val = $self->$method(); $args{$a} = $val if defined $val; } # Handle verbose, quiet, really_quiet flags my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, ); my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 } keys %verb_map; die "Only one of verbose, quiet or really_quiet should be specified\n" if @verb_adj > 1; $args{verbosity} = shift @verb_adj || 0; for my $a (qw( merge failures comments timer directives normalize )) { $args{$a} = 1 if $self->$a(); } $args{errors} = 1 if $self->parse; # defined but zero-length exec runs test files as binaries $args{exec} = [ split( /\s+/, $self->exec ) ] if ( defined( $self->exec ) ); $args{version} = $self->tapversion if defined( $self->tapversion ); if ( defined( my $test_args = $self->test_args ) ) { $args{test_args} = $test_args; } if ( @{ $self->rules } ) { my @rules; for ( @{ $self->rules } ) { if (/^par=(.*)/) { push @rules, $1; } elsif (/^seq=(.*)/) { push @rules, { seq => $1 }; } } $args{rules} = { par => [@rules] }; } $args{harness_class} = $self->{harness_class} if $self->{harness_class}; return \%args; } sub _find_module { my ( $self, $class, @search ) = @_; croak "Bad module name $class" unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; for my $pfx (@search) { my $name = join( '::', $pfx, $class ); eval "require $name"; return $name unless $@; } eval "require $class"; return $class unless $@; return; } sub _load_extension { my ( $self, $name, @search ) = @_; my @args = (); if ( $name =~ /^(.*?)=(.*)/ ) { $name = $1; @args = split( /,/, $2 ); } if ( my $class = $self->_find_module( $name, @search ) ) { $class->import(@args); if ( $class->can('load') ) { $class->load( { app_prove => $self, args => [@args] } ); } } else { croak "Can't load module $name"; } } sub _load_extensions { my ( $self, $ext, @search ) = @_; $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 ( $name, $k, $v ) = @_; if ( $v =~ /(? $v; } else { $config{$k} = $v; } } } ); $self->{argv} = \@ARGV; return ( $handler, \%config ); } =head3 C Perform whatever actions the command line args specified. The C command line tool consists of the following code: use App::Prove; my $app = App::Prove->new; $app->process_args(@ARGV); exit( $app->run ? 0 : 1 ); # if you need the exit code =cut sub run { my $self = shift; unless ( $self->state_manager ) { $self->state_manager( $self->state_class->new( { store => STATE_FILE } ) ); } if ( $self->show_help ) { $self->_help(1); } elsif ( $self->show_man ) { $self->_help(2); } elsif ( $self->show_version ) { $self->print_version; } elsif ( $self->dry ) { print "$_\n" for $self->_get_tests; } else { $self->_load_extensions( $self->modules ); $self->_load_extensions( $self->plugins, PLUGINS ); local $ENV{TEST_VERBOSE} = 1 if $self->verbose; return $self->_runtests( $self->_get_args, $self->_get_tests ); } return 1; } sub _get_tests { my $self = shift; my $state = $self->state_manager; my $ext = $self->extensions; $state->extensions($ext) if defined $ext; if ( defined( my $state_switch = $self->state ) ) { $state->apply_switch(@$state_switch); } my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); $self->_shuffle(@tests) if $self->shuffle; @tests = reverse @tests if $self->backwards; return @tests; } sub _runtests { my ( $self, $args, @tests ) = @_; my $harness = TAP::Harness::Env->create($args); my $state = $self->state_manager; $harness->callback( after_test => sub { $state->observe_test(@_); } ); $harness->callback( after_runtests => sub { $state->commit(@_); } ); my $aggregator = $harness->runtests(@tests); return !$aggregator->has_errors; } sub _get_switches { my $self = shift; my @switches; # notes that -T or -t must be at the front of the switches! if ( $self->taint_fail ) { push @switches, '-T'; } elsif ( $self->taint_warn ) { push @switches, '-t'; } if ( $self->warnings_fail ) { push @switches, '-W'; } elsif ( $self->warnings_warn ) { push @switches, '-w'; } return @switches ? \@switches : (); } sub _get_lib { my $self = shift; my @libs; if ( $self->lib ) { push @libs, 'lib'; } if ( $self->blib ) { push @libs, 'blib/lib', 'blib/arch'; } if ( @{ $self->includes } ) { push @libs, @{ $self->includes }; } #24926 @libs = map { File::Spec->rel2abs($_) } @libs; # Huh? return @libs ? \@libs : (); } sub _shuffle { my $self = shift; # Fisher-Yates shuffle my $i = @_; while ($i) { my $j = rand $i--; @_[ $i, $j ] = @_[ $j, $i ]; } return; } =head3 C Load a harness replacement class. $prove->require_harness($for => $class_name); =cut sub require_harness { my ( $self, $for, $class ) = @_; my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/; # Emulate Perl's -MModule=arg1,arg2 behaviour $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!; eval("use $class;"); die "$class_name is required to use the --$for feature: $@" if $@; $self->{harness_class} = $class_name; return; } =head3 C Display the version numbers of the loaded L and the current Perl. =cut sub print_version { my $self = shift; require TAP::Harness; printf( "TAP::Harness v%s and Perl v%vd\n", $TAP::Harness::VERSION, $^V ); return; } 1; # vim:ts=4:sw=4:et:sta __END__ =head2 Attributes After command line parsing the following attributes reflect the values of the corresponding command line switches. They may be altered before calling C. =over =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =back =head1 PLUGINS C provides support for 3rd-party plugins. These are currently loaded at run-time, I arguments have been parsed (so you can not change the way arguments are processed, sorry), typically with the C<< -PI >> switch, eg: prove -PMyPlugin This will search for a module named C, or failing that, C. If the plugin can't be found, C will complain & exit. You can pass an argument to your plugin by appending an C<=> after the plugin name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas: prove -PMyPlugin=foo,bar,baz These are passed in to your plugin's C class method (if it has one), along with a reference to the C object that is invoking your plugin: sub load { my ($class, $p) = @_; my @args = @{ $p->{args} }; # @args will contain ( 'foo', 'bar', 'baz' ) $p->{app_prove}->do_something; ... } Note that the user's arguments are also passed to your plugin's C function as a list, eg: sub import { my ($class, @args) = @_; # @args will contain ( 'foo', 'bar', 'baz' ) ... } This is for backwards compatibility, and may be deprecated in the future. =head2 Sample Plugin Here's a sample plugin, for your reference: package App::Prove::Plugin::Foo; # Sample plugin, try running with: # prove -PFoo=bar -r -j3 # prove -PFoo -Q # prove -PFoo=bar,My::Formatter use strict; use warnings; sub load { my ($class, $p) = @_; my @args = @{ $p->{args} }; my $app = $p->{app_prove}; print "loading plugin: $class, args: ", join(', ', @args ), "\n"; # turn on verbosity $app->verbose( 1 ); # set the formatter? $app->formatter( $args[1] ) if @args > 1; # print some of App::Prove's state: for my $attr (qw( jobs quiet really_quiet recurse verbose )) { my $val = $app->$attr; $val = 'undef' unless defined( $val ); print "$attr: $val\n"; } return 1; } 1; =head1 SEE ALSO L, L =cut Test-Harness-3.36/lib/App/Prove/0000755000175000017500000000000012640746441015032 5ustar leonleonTest-Harness-3.36/lib/App/Prove/State.pm0000644000175000017500000002665112640746046016463 0ustar leonleonpackage App::Prove::State; use strict; use warnings; use File::Find; use File::Spec; use Carp; use App::Prove::State::Result; use TAP::Parser::YAMLish::Reader (); use TAP::Parser::YAMLish::Writer (); use base 'TAP::Base'; BEGIN { __PACKAGE__->mk_methods('result_class'); } use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant NEED_GLOB => IS_WIN32; =head1 NAME App::Prove::State - State storage for the C command. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION The C command supports a C<--state> option that instructs it to store persistent state across runs. This module implements that state and the operations that may be performed on it. =head1 SYNOPSIS # Re-run failed tests $ prove --state=failed,save -rbv =cut =head1 METHODS =head2 Class Methods =head3 C Accepts a hashref with the following key/value pairs: =over 4 =item * C The filename of the data store holding the data that App::Prove::State reads. =item * C (optional) The test name extensions. Defaults to C<.t>. =item * C (optional) The name of the C. Defaults to C. =back =cut # override TAP::Base::new: sub new { my $class = shift; my %args = %{ shift || {} }; my $self = bless { select => [], seq => 1, store => delete $args{store}, extensions => ( delete $args{extensions} || ['.t'] ), result_class => ( delete $args{result_class} || 'App::Prove::State::Result' ), }, $class; $self->{_} = $self->result_class->new( { tests => {}, generation => 1, } ); my $store = $self->{store}; $self->load($store) if defined $store && -f $store; return $self; } =head2 C Getter/setter for the name of the class used for tracking test results. This class should either subclass from C or provide an identical interface. =cut =head2 C Get or set the list of extensions that files must have in order to be considered tests. Defaults to ['.t']. =cut sub extensions { my $self = shift; $self->{extensions} = shift if @_; return $self->{extensions}; } =head2 C Get the results of the last test run. Returns a C instance. =cut sub results { my $self = shift; $self->{_} || $self->result_class->new; } =head2 C Save the test results. Should be called after all tests have run. =cut sub commit { my $self = shift; if ( $self->{should_save} ) { $self->save; } } =head2 Instance Methods =head3 C $self->apply_switch('failed,save'); Apply a list of switch options to the state, updating the internal object state as a result. Nothing is returned. Diagnostics: - "Illegal state option: %s" =over =item C Run in the same order as last time =item C Run only the failed tests from last time =item C Run only the passed tests from last time =item C Run all tests in normal order =item C Run the tests that most recently failed first =item C Run the tests ordered by number of todos. =item C Run the tests in slowest to fastest order. =item C Run test tests in fastest to slowest order. =item C Run the tests in newest to oldest order. =item C Run the tests in oldest to newest order. =item C Save the state on exit. =back =cut sub apply_switch { my $self = shift; my @opts = @_; my $last_gen = $self->results->generation - 1; my $last_run_time = $self->results->last_run_time; my $now = $self->get_time; my @switches = map { split /,/ } @opts; my %handler = ( last => sub { $self->_select( limit => shift, where => sub { $_->generation >= $last_gen }, order => sub { $_->sequence } ); }, failed => sub { $self->_select( limit => shift, where => sub { $_->result != 0 }, order => sub { -$_->result } ); }, passed => sub { $self->_select( limit => shift, where => sub { $_->result == 0 } ); }, all => sub { $self->_select( limit => shift ); }, todo => sub { $self->_select( limit => shift, where => sub { $_->num_todo != 0 }, order => sub { -$_->num_todo; } ); }, hot => sub { $self->_select( limit => shift, where => sub { defined $_->last_fail_time }, order => sub { $now - $_->last_fail_time } ); }, slow => sub { $self->_select( limit => shift, order => sub { -$_->elapsed } ); }, fast => sub { $self->_select( limit => shift, order => sub { $_->elapsed } ); }, new => sub { $self->_select( limit => shift, order => sub { -$_->mtime } ); }, old => sub { $self->_select( limit => shift, order => sub { $_->mtime } ); }, fresh => sub { $self->_select( limit => shift, where => sub { $_->mtime >= $last_run_time } ); }, save => sub { $self->{should_save}++; }, adrian => sub { unshift @switches, qw( hot all save ); }, ); while ( defined( my $ele = shift @switches ) ) { my ( $opt, $arg ) = ( $ele =~ /^([^:]+):(.*)/ ) ? ( $1, $2 ) : ( $ele, undef ); my $code = $handler{$opt} || croak "Illegal state option: $opt"; $code->($arg); } return; } sub _select { my ( $self, %spec ) = @_; push @{ $self->{select} }, \%spec; } =head3 C Given a list of args get the names of tests that should run =cut sub get_tests { my $self = shift; my $recurse = shift; my @argv = @_; my %seen; my @selected = $self->_query; unless ( @argv || @{ $self->{select} } ) { @argv = $recurse ? '.' : 't'; croak qq{No tests named and '@argv' directory not found} unless -d $argv[0]; } push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv; return grep { !$seen{$_}++ } @selected; } sub _query { my $self = shift; if ( my @sel = @{ $self->{select} } ) { warn "No saved state, selection will be empty\n" unless $self->results->num_tests; return map { $self->_query_clause($_) } @sel; } return; } sub _query_clause { my ( $self, $clause ) = @_; my @got; my $results = $self->results; my $where = $clause->{where} || sub {1}; # Select for my $name ( $results->test_names ) { next unless -f $name; local $_ = $results->test($name); push @got, $name if $where->(); } # Sort if ( my $order = $clause->{order} ) { @got = map { $_->[0] } sort { ( defined $b->[1] <=> defined $a->[1] ) || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) ) } map { [ $_, do { local $_ = $results->test($_); $order->() } ] } @got; } if ( my $limit = $clause->{limit} ) { @got = splice @got, 0, $limit if @got > $limit; } return @got; } sub _get_raw_tests { my $self = shift; my $recurse = shift; my @argv = @_; my @tests; # Do globbing on Win32. if (NEED_GLOB) { eval "use File::Glob::Windows"; # [49732] @argv = map { glob "$_" } @argv; } my $extensions = $self->{extensions}; for my $arg (@argv) { if ( '-' eq $arg ) { push @argv => ; chomp(@argv); next; } push @tests, sort -d $arg ? $recurse ? $self->_expand_dir_recursive( $arg, $extensions ) : map { glob( File::Spec->catfile( $arg, "*$_" ) ) } @{$extensions} : $arg; } return @tests; } sub _expand_dir_recursive { my ( $self, $dir, $extensions ) = @_; my @tests; my $ext_string = join( '|', map {quotemeta} @{$extensions} ); find( { follow => 1, #21938 follow_skip => 2, wanted => sub { -f && /(?:$ext_string)$/ && push @tests => $File::Find::name; } }, $dir ); return @tests; } =head3 C Store the results of a test. =cut # Store: # last fail time # last pass time # last run time # most recent result # most recent todos # total failures # total passes # state generation # parser sub observe_test { my ( $self, $test_info, $parser ) = @_; my $name = $test_info->[0]; my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ); my $todo = scalar( $parser->todo ); my $start_time = $parser->start_time; my $end_time = $parser->end_time, my $test = $self->results->test($name); $test->sequence( $self->{seq}++ ); $test->generation( $self->results->generation ); $test->run_time($end_time); $test->result($fail); $test->num_todo($todo); $test->elapsed( $end_time - $start_time ); $test->parser($parser); if ($fail) { $test->total_failures( $test->total_failures + 1 ); $test->last_fail_time($end_time); } else { $test->total_passes( $test->total_passes + 1 ); $test->last_pass_time($end_time); } } =head3 C Write the state to a file. =cut sub save { my ($self) = @_; my $store = $self->{store} or return; $self->results->last_run_time( $self->get_time ); my $writer = TAP::Parser::YAMLish::Writer->new; local *FH; open FH, ">$store" or croak "Can't write $store ($!)"; $writer->write( $self->results->raw, \*FH ); close FH; } =head3 C Load the state from a file =cut sub load { my ( $self, $name ) = @_; my $reader = TAP::Parser::YAMLish::Reader->new; local *FH; open FH, "<$name" or croak "Can't read $name ($!)"; # XXX this is temporary $self->{_} = $self->result_class->new( $reader->read( sub { my $line = ; defined $line && chomp $line; return $line; } ) ); # $writer->write( $self->{tests} || {}, \*FH ); close FH; $self->_regen_seq; $self->_prune_and_stamp; $self->results->generation( $self->results->generation + 1 ); } sub _prune_and_stamp { my $self = shift; my $results = $self->results; my @tests = $self->results->tests; for my $test (@tests) { my $name = $test->name; if ( my @stat = stat $name ) { $test->mtime( $stat[9] ); } else { $results->remove($name); } } } sub _regen_seq { my $self = shift; for my $test ( $self->results->tests ) { $self->{seq} = $test->sequence + 1 if defined $test->sequence && $test->sequence >= $self->{seq}; } } 1; Test-Harness-3.36/lib/App/Prove/State/0000755000175000017500000000000012640746441016112 5ustar leonleonTest-Harness-3.36/lib/App/Prove/State/Result.pm0000644000175000017500000001152112640746046017727 0ustar leonleonpackage App::Prove::State::Result; use strict; use warnings; use Carp 'croak'; use App::Prove::State::Result::Test; use constant STATE_VERSION => 1; =head1 NAME App::Prove::State::Result - Individual test suite results. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION The C command supports a C<--state> option that instructs it to store persistent state across runs. This module encapsulates the results for a single test suite run. =head1 SYNOPSIS # Re-run failed tests $ prove --state=failed,save -rbv =cut =head1 METHODS =head2 Class Methods =head3 C my $result = App::Prove::State::Result->new({ generation => $generation, tests => \%tests, }); Returns a new C instance. =cut sub new { my ( $class, $arg_for ) = @_; $arg_for ||= {}; my %instance_data = %$arg_for; # shallow copy $instance_data{version} = $class->state_version; my $tests = delete $instance_data{tests} || {}; my $self = bless \%instance_data => $class; $self->_initialize($tests); return $self; } sub _initialize { my ( $self, $tests ) = @_; my %tests; while ( my ( $name, $test ) = each %$tests ) { $tests{$name} = $self->test_class->new( { %$test, name => $name } ); } $self->tests( \%tests ); return $self; } =head2 C Returns the current version of state storage. =cut sub state_version {STATE_VERSION} =head2 C Returns the name of the class used for tracking individual tests. This class should either subclass from C or provide an identical interface. =cut sub test_class { return 'App::Prove::State::Result::Test'; } my %methods = ( generation => { method => 'generation', default => 0 }, last_run_time => { method => 'last_run_time', default => undef }, ); while ( my ( $key, $description ) = each %methods ) { my $default = $description->{default}; no strict 'refs'; *{ $description->{method} } = sub { my $self = shift; if (@_) { $self->{$key} = shift; return $self; } return $self->{$key} || $default; }; } =head3 C Getter/setter for the "generation" of the test suite run. The first generation is 1 (one) and subsequent generations are 2, 3, etc. =head3 C Getter/setter for the time of the test suite run. =head3 C Returns the tests for a given generation. This is a hashref or a hash, depending on context called. The keys to the hash are the individual test names and the value is a hashref with various interesting values. Each k/v pair might resemble something like this: 't/foo.t' => { elapsed => '0.0428488254547119', gen => '7', last_pass_time => '1219328376.07815', last_result => '0', last_run_time => '1219328376.07815', last_todo => '0', mtime => '1191708862', seq => '192', total_passes => '6', } =cut sub tests { my $self = shift; if (@_) { $self->{tests} = shift; return $self; } my %tests = %{ $self->{tests} }; my @tests = sort { $a->sequence <=> $b->sequence } values %tests; return wantarray ? @tests : \@tests; } =head3 C my $test = $result->test('t/customer/create.t'); Returns an individual C instance for the given test name (usually the filename). Will return a new C instance if the name is not found. =cut sub test { my ( $self, $name ) = @_; croak("test() requires a test name") unless defined $name; my $tests = $self->{tests} ||= {}; if ( my $test = $tests->{$name} ) { return $test; } else { my $test = $self->test_class->new( { name => $name } ); $self->{tests}->{$name} = $test; return $test; } } =head3 C Returns an list of test names, sorted by run order. =cut sub test_names { my $self = shift; return map { $_->name } $self->tests; } =head3 C $result->remove($test_name); # remove the test my $test = $result->test($test_name); # fatal error Removes a given test from results. This is a no-op if the test name is not found. =cut sub remove { my ( $self, $name ) = @_; delete $self->{tests}->{$name}; return $self; } =head3 C Returns the number of tests for a given test suite result. =cut sub num_tests { keys %{ shift->{tests} } } =head3 C Returns a hashref of raw results, suitable for serialization by YAML. =cut sub raw { my $self = shift; my %raw = %$self; my %tests; for my $test ( $self->tests ) { $tests{ $test->name } = $test->raw; } $raw{tests} = \%tests; return \%raw; } 1; Test-Harness-3.36/lib/App/Prove/State/Result/0000755000175000017500000000000012640746441017370 5ustar leonleonTest-Harness-3.36/lib/App/Prove/State/Result/Test.pm0000644000175000017500000000653212640746046020654 0ustar leonleonpackage App::Prove::State::Result::Test; use strict; use warnings; =head1 NAME App::Prove::State::Result::Test - Individual test results. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION The C command supports a C<--state> option that instructs it to store persistent state across runs. This module encapsulates the results for a single test. =head1 SYNOPSIS # Re-run failed tests $ prove --state=failed,save -rbv =cut my %methods = ( name => { method => 'name' }, elapsed => { method => 'elapsed', default => 0 }, gen => { method => 'generation', default => 1 }, last_pass_time => { method => 'last_pass_time', default => undef }, last_fail_time => { method => 'last_fail_time', default => undef }, last_result => { method => 'result', default => 0 }, last_run_time => { method => 'run_time', default => undef }, last_todo => { method => 'num_todo', default => 0 }, mtime => { method => 'mtime', default => undef }, seq => { method => 'sequence', default => 1 }, total_passes => { method => 'total_passes', default => 0 }, total_failures => { method => 'total_failures', default => 0 }, parser => { method => 'parser' }, ); while ( my ( $key, $description ) = each %methods ) { my $default = $description->{default}; no strict 'refs'; *{ $description->{method} } = sub { my $self = shift; if (@_) { $self->{$key} = shift; return $self; } return $self->{$key} || $default; }; } =head1 METHODS =head2 Class Methods =head3 C =cut sub new { my ( $class, $arg_for ) = @_; $arg_for ||= {}; bless $arg_for => $class; } =head2 Instance Methods =head3 C The name of the test. Usually a filename. =head3 C The total elapsed times the test took to run, in seconds from the epoch.. =head3 C The number for the "generation" of the test run. The first generation is 1 (one) and subsequent generations are 2, 3, etc. =head3 C The last time the test program passed, in seconds from the epoch. Returns C if the program has never passed. =head3 C The last time the test suite failed, in seconds from the epoch. Returns C if the program has never failed. =head3 C Returns the mtime of the test, in seconds from the epoch. =head3 C Returns a hashref of raw test data, suitable for serialization by YAML. =head3 C Currently, whether or not the test suite passed with no 'problems' (such as TODO passed). =head3 C The total time it took for the test to run, in seconds. If C is available, it will have finer granularity. =head3 C The number of tests with TODO directives. =head3 C The order in which this test was run for the given test suite result. =head3 C The number of times the test has passed. =head3 C The number of times the test has failed. =head3 C The underlying parser object. This is useful if you need the full information for the test program. =cut sub raw { my $self = shift; my %raw = %$self; # this is backwards-compatibility hack and is not guaranteed. delete $raw{name}; delete $raw{parser}; return \%raw; } 1; Test-Harness-3.36/lib/TAP/0000755000175000017500000000000012640746441013643 5ustar leonleonTest-Harness-3.36/lib/TAP/Parser/0000755000175000017500000000000012640746441015077 5ustar leonleonTest-Harness-3.36/lib/TAP/Parser/IteratorFactory.pm0000644000175000017500000001752612640746046020572 0ustar leonleonpackage TAP::Parser::IteratorFactory; use strict; use warnings; use Carp qw( confess ); use File::Basename qw( fileparse ); use base 'TAP::Object'; use constant handlers => []; =head1 NAME TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::IteratorFactory; my $factory = TAP::Parser::IteratorFactory->new({ %config }); my $iterator = $factory->make_iterator( $filename ); =head1 DESCRIPTION This is a factory class that takes a L and runs it through all the registered Ls to see which one should handle the source. If you're a plugin author, you'll be interested in how to Ls, how L works. =head1 METHODS =head2 Class Methods =head3 C Creates a new factory class: my $sf = TAP::Parser::IteratorFactory->new( $config ); C<$config> is optional. If given, sets L and calls L. =cut sub _initialize { my ( $self, $config ) = @_; $self->config( $config || {} )->load_handlers; return $self; } =head3 C Registers a new L with this factory. __PACKAGE__->register_handler( $handler_class ); =head3 C List of handlers that have been registered. =cut sub register_handler { my ( $class, $dclass ) = @_; 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 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 $sf->load_handlers; Loads the handler classes defined in L. For example, given a config: $sf->config({ MySourceHandler => { some => 'config' }, }); C will attempt to load the C class by looking in C<@INC> for it in this order: TAP::Parser::SourceHandler::MySourceHandler MySourceHandler Cs on error. =cut 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 _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 ) ); } ############################################################################## =head3 C my $iterator = $src_factory->make_iterator( $source ); Given a L, finds the most suitable L to use to create a L (see L). 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; } =head3 C Given a L, detects what kind of source it is and returns I L (the most confident one). Dies on error. 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 ) = @_; confess('no raw source ref defined!') unless defined $source->raw; # find a list of handlers that can handle this source: my %handlers; for my $dclass ( @{ $self->handlers } ) { my $confidence = $dclass->can_handle($source); # 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; } # 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; __END__ =head1 SUBCLASSING Please see L 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 for that). But in case you find the need to... package MyIteratorFactory; use strict; use base 'TAP::Parser::IteratorFactory'; # 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. Moved out of L & converted to a factory class to support extensible TAP source detective work by Steve Purkis. =head1 SEE ALSO L, L, L, L, L, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/ResultFactory.pm0000644000175000017500000000774112640746046020255 0ustar leonleonpackage TAP::Parser::ResultFactory; use strict; use warnings; use TAP::Parser::Result::Bailout (); use TAP::Parser::Result::Comment (); use TAP::Parser::Result::Plan (); use TAP::Parser::Result::Pragma (); use TAP::Parser::Result::Test (); use TAP::Parser::Result::Unknown (); use TAP::Parser::Result::Version (); use TAP::Parser::Result::YAML (); use base 'TAP::Object'; ############################################################################## =head1 NAME TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 SYNOPSIS use TAP::Parser::ResultFactory; my $token = {...}; my $factory = TAP::Parser::ResultFactory->new; my $result = $factory->make_result( $token ); =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head2 DESCRIPTION This is a simple factory class which returns a L subclass representing the current bit of test data from TAP (usually a single line). It is used primarily by L. Unless you're subclassing, you probably won't need to use this module directly. =head2 METHODS =head2 Class Methods =head3 C Creates a new factory class. I You currently don't need to instantiate a factory in order to use it. =head3 C Returns an instance the appropriate class for the test token passed in. my $result = TAP::Parser::ResultFactory->make_result($token); Can also be called as an instance method. =cut sub make_result { my ( $proto, $token ) = @_; my $type = $token->{type}; return $proto->class_for($type)->new($token); } =head3 C Takes one argument: C<$type>. Returns the class for this $type, or Cs with an error. =head3 C Takes two arguments: C<$type>, C<$class> This lets you override an existing type with your own custom type, or register a completely new type, eg: # create a custom result type: package MyResult; use strict; use base 'TAP::Parser::Result'; # register with the factory: TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); # use it: my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } ); Your custom type should then be picked up automatically by the L. =cut our %CLASS_FOR = ( plan => 'TAP::Parser::Result::Plan', pragma => 'TAP::Parser::Result::Pragma', test => 'TAP::Parser::Result::Test', comment => 'TAP::Parser::Result::Comment', bailout => 'TAP::Parser::Result::Bailout', version => 'TAP::Parser::Result::Version', unknown => 'TAP::Parser::Result::Unknown', yaml => 'TAP::Parser::Result::YAML', ); sub class_for { my ( $class, $type ) = @_; # return target class: return $CLASS_FOR{$type} if exists $CLASS_FOR{$type}; # or complain: require Carp; Carp::croak("Could not determine class for result type '$type'"); } sub register_type { my ( $class, $type, $rclass ) = @_; # register it blindly, assume they know what they're doing $CLASS_FOR{$type} = $rclass; return $class; } 1; =head1 SUBCLASSING Please see L for a subclassing overview. There are a few things to bear in mind when creating your own C: =over 4 =item 1 The factory itself is never instantiated (this I change in the future). This means that C<_initialize> is never called. =item 2 Cnew> is never called, $tokens are reblessed. This I change in a future version! =item 3 L subclasses will register themselves with L directly: package MyFooResult; TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ ); Of course, it's up to you to decide whether or not to ignore them. =back =head2 Example package MyResultFactory; use strict; use MyResult; use base 'TAP::Parser::ResultFactory'; # force all results to be 'MyResult' sub class_for { return 'MyResult'; } 1; =head1 SEE ALSO L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/Multiplexer.pm0000644000175000017500000001025112640746046017747 0ustar leonleonpackage TAP::Parser::Multiplexer; use strict; use warnings; use IO::Select; use base 'TAP::Object'; use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/; use constant IS_VMS => $^O eq 'VMS'; use constant SELECT_OK => !( IS_VMS || IS_WIN32 ); =head1 NAME TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Multiplexer; my $mux = TAP::Parser::Multiplexer->new; $mux->add( $parser1, $stash1 ); $mux->add( $parser2, $stash2 ); while ( my ( $parser, $stash, $result ) = $mux->next ) { # do stuff } =head1 DESCRIPTION C gathers input from multiple TAP::Parsers. Internally it calls select on the input file handles for those parsers to wait for one or more of them to have input available. See L for an example of its use. =head1 METHODS =head2 Class Methods =head3 C my $mux = TAP::Parser::Multiplexer->new; Returns a new C object. =cut # new() implementation supplied by TAP::Object sub _initialize { my $self = shift; $self->{select} = IO::Select->new; $self->{avid} = []; # Parsers that can't select $self->{count} = 0; return $self; } ############################################################################## =head2 Instance Methods =head3 C $mux->add( $parser, $stash ); Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque reference that will be returned from C along with the parser and the next result. =cut sub add { my ( $self, $parser, $stash ) = @_; if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) { my $sel = $self->{select}; # We have to turn handles into file numbers here because by # the time we want to remove them from our IO::Select they # will already have been closed by the iterator. my @filenos = map { fileno $_ } @handles; for my $h (@handles) { $sel->add( [ $h, $parser, $stash, @filenos ] ); } $self->{count}++; } else { push @{ $self->{avid} }, [ $parser, $stash ]; } } =head3 C my $count = $mux->parsers; Returns the number of parsers. Parsers are removed from the multiplexer when their input is exhausted. =cut sub parsers { my $self = shift; return $self->{count} + scalar @{ $self->{avid} }; } sub _iter { my $self = shift; my $sel = $self->{select}; my $avid = $self->{avid}; my @ready = (); return sub { # Drain all the non-selectable parsers first if (@$avid) { my ( $parser, $stash ) = @{ $avid->[0] }; my $result = $parser->next; shift @$avid unless defined $result; return ( $parser, $stash, $result ); } unless (@ready) { return unless $sel->count; @ready = $sel->can_read; } my ( $h, $parser, $stash, @handles ) = @{ shift @ready }; my $result = $parser->next; unless ( defined $result ) { $sel->remove(@handles); $self->{count}--; # Force another can_read - we may now have removed a handle # thought to have been ready. @ready = (); } return ( $parser, $stash, $result ); }; } =head3 C Return a result from the next available parser. Returns a list containing the parser from which the result came, the stash that corresponds with that parser and the result. my ( $parser, $stash, $result ) = $mux->next; If C<$result> is undefined the corresponding parser has reached the end of its input (and will automatically be removed from the multiplexer). When all parsers are exhausted an empty list will be returned. if ( my ( $parser, $stash, $result ) = $mux->next ) { if ( ! defined $result ) { # End of this parser } else { # Process result } } else { # All parsers finished } =cut sub next { my $self = shift; return ( $self->{_iter} ||= $self->_iter )->(); } =head1 See Also L L =cut 1; Test-Harness-3.36/lib/TAP/Parser/Aggregator.pm0000644000175000017500000002203312640746046017520 0ustar leonleonpackage TAP::Parser::Aggregator; use strict; use warnings; use Benchmark; use base 'TAP::Object'; =head1 NAME TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Aggregator; my $aggregate = TAP::Parser::Aggregator->new; $aggregate->add( 't/00-load.t', $load_parser ); $aggregate->add( 't/10-lex.t', $lex_parser ); my $summary = <<'END_SUMMARY'; Passed: %s Failed: %s Unexpectedly succeeded: %s END_SUMMARY printf $summary, scalar $aggregate->passed, scalar $aggregate->failed, scalar $aggregate->todo_passed; =head1 DESCRIPTION C collects parser objects and allows reporting/querying their aggregate results. =head1 METHODS =head2 Class Methods =head3 C my $aggregate = TAP::Parser::Aggregator->new; Returns a new C object. =cut # new() implementation supplied by TAP::Object my %SUMMARY_METHOD_FOR; BEGIN { # install summary methods %SUMMARY_METHOD_FOR = map { $_ => $_ } qw( failed parse_errors passed skipped todo todo_passed total wait exit ); $SUMMARY_METHOD_FOR{total} = 'tests_run'; $SUMMARY_METHOD_FOR{planned} = 'tests_planned'; for my $method ( keys %SUMMARY_METHOD_FOR ) { next if 'total' eq $method; no strict 'refs'; *$method = sub { my $self = shift; return wantarray ? @{ $self->{"descriptions_for_$method"} } : $self->{$method}; }; } } # end install summary methods sub _initialize { my ($self) = @_; $self->{parser_for} = {}; $self->{parse_order} = []; for my $summary ( keys %SUMMARY_METHOD_FOR ) { $self->{$summary} = 0; next if 'total' eq $summary; $self->{"descriptions_for_$summary"} = []; } return $self; } ############################################################################## =head2 Instance Methods =head3 C $aggregate->add( $description => $parser ); The C<$description> is usually a test file name (but only by convention.) It is used as a unique identifier (see e.g. L<"parsers">.) Reusing a description is a fatal error. The C<$parser> is a L object. =cut sub add { my ( $self, $description, $parser ) = @_; if ( exists $self->{parser_for}{$description} ) { $self->_croak( "You already have a parser for ($description)." . " Perhaps you have run the same test twice." ); } push @{ $self->{parse_order} } => $description; $self->{parser_for}{$description} = $parser; while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) { # Slightly nasty. Instead we should maybe have 'cooked' accessors # for results that may be masked by the parser. next if ( $method eq 'exit' || $method eq 'wait' ) && $parser->ignore_exit; if ( my $count = $parser->$method() ) { $self->{$summary} += $count; push @{ $self->{"descriptions_for_$summary"} } => $description; } } return $self; } ############################################################################## =head3 C my $count = $aggregate->parsers; my @parsers = $aggregate->parsers; my @parsers = $aggregate->parsers(@descriptions); In scalar context without arguments, this method returns the number of parsers aggregated. In list context without arguments, returns the parsers in the order they were added. If C<@descriptions> is given, these correspond to the keys used in each call to the add() method. Returns an array of the requested parsers (in the requested order) in list context or an array reference in scalar context. Requesting an unknown identifier is a fatal error. =cut sub parsers { my $self = shift; return $self->_get_parsers(@_) if @_; my $descriptions = $self->{parse_order}; my @parsers = @{ $self->{parser_for} }{@$descriptions}; # Note: Because of the way context works, we must assign the parsers to # the @parsers array or else this method does not work as documented. return @parsers; } sub _get_parsers { my ( $self, @descriptions ) = @_; my @parsers; 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}; } return wantarray ? @parsers : \@parsers; } =head3 C Get an array of descriptions in the order in which they were added to the aggregator. =cut sub descriptions { @{ shift->{parse_order} || [] } } =head3 C Call C immediately before adding any results to the aggregator. Among other times it records the start time for the test run. =cut sub start { my $self = shift; $self->{start_time} = Benchmark->new; } =head3 C Call C immediately after adding all test results to the aggregator. =cut sub stop { my $self = shift; $self->{end_time} = Benchmark->new; } =head3 C Elapsed returns a L object that represents the running time of the aggregated tests. In order for C to be valid you must call C before running the tests and C immediately afterwards. =cut sub elapsed { my $self = shift; require Carp; Carp::croak q{Can't call elapsed without first calling start and then stop} unless defined $self->{start_time} && defined $self->{end_time}; return timediff( $self->{end_time}, $self->{start_time} ); } =head3 C Returns a formatted string representing the runtime returned by C. This lets the caller not worry about Benchmark. =cut sub elapsed_timestr { my $self = shift; my $elapsed = $self->elapsed; return timestr($elapsed); } =head3 C Return true if all the tests passed and no parse errors were detected. =cut sub all_passed { my $self = shift; return $self->total && $self->total == $self->passed && !$self->has_errors; } =head3 C Get a single word describing the status of the aggregated tests. Depending on the outcome of the tests returns 'PASS', 'FAIL' or 'NOTESTS'. This token is understood by L. =cut sub get_status { my $self = shift; my $total = $self->total; my $passed = $self->passed; return ( $self->has_errors || $total != $passed ) ? 'FAIL' : $total ? 'PASS' : 'NOTESTS'; } ############################################################################## =head2 Summary methods Each of the following methods will return the total number of corresponding tests if called in scalar context. If called in list context, returns the descriptions of the parsers which contain the corresponding tests (see C for an explanation of description. =over 4 =item * failed =item * parse_errors =item * passed =item * planned =item * skipped =item * todo =item * todo_passed =item * wait =item * exit =back For example, to find out how many tests unexpectedly succeeded (TODO tests which passed when they shouldn't): my $count = $aggregate->todo_passed; my @descriptions = $aggregate->todo_passed; Note that C and C are the totals of the wait and exit statuses of each of the tests. These values are totalled only to provide a true value if any of them are non-zero. =cut ############################################################################## =head3 C my $tests_run = $aggregate->total; Returns the total number of tests run. =cut sub total { shift->{total} } ############################################################################## =head3 C if ( $parser->has_problems ) { ... } Identical to C, but also returns true if any TODO tests unexpectedly succeeded. This is more akin to "warnings". =cut sub has_problems { my $self = shift; return $self->todo_passed || $self->has_errors; } ############################################################################## =head3 C if ( $parser->has_errors ) { ... } Returns true if I of the parsers failed. This includes: =over 4 =item * Failed tests =item * Parse errors =item * Bad exit or wait status =back =cut sub has_errors { my $self = shift; return $self->failed || $self->parse_errors || $self->exit || $self->wait; } ############################################################################## =head3 C # deprecated in favor of 'todo_passed'. This method was horribly misnamed. This was a badly misnamed method. It indicates which TODO tests unexpectedly succeeded. Will now issue a warning and call C. =cut sub todo_failed { warn '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; goto &todo_passed; } =head1 See Also L L =cut 1; Test-Harness-3.36/lib/TAP/Parser/Source.pm0000644000175000017500000002251712640746046016705 0ustar leonleonpackage TAP::Parser::Source; use strict; use warnings; use File::Basename qw( fileparse ); use base 'TAP::Object'; use constant BLK_SIZE => 512; =head1 NAME TAP::Parser::Source - a TAP source & meta data about it =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Source; my $source = TAP::Parser::Source->new; $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 A TAP I 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. Cs encapsulate these I sources, and provide some useful meta data about them. They are used by Ls, which do whatever is required to produce & capture a stream of TAP from the I source, and package it up in a L for the parser to consume. Unless you're writing a new L, a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C my $source = TAP::Parser::Source->new; Returns a new C object. =cut # new() implementation supplied by TAP::Object sub _initialize { my ($self) = @_; $self->meta( {} ); $self->config( {} ); return $self; } ############################################################################## =head2 Instance Methods =head3 C my $raw = $source->raw; $source->raw( $some_value ); Chaining getter/setter for the raw TAP source. This is a reference, as it may contain large amounts of data (eg: raw TAP). =head3 C my $meta = $source->meta; $source->meta({ %some_value }); Chaining getter/setter for meta data about the source. This defaults to an empty hashref. See L for more info. =head3 C True if the source has meta data. =head3 C my $config = $source->config; $source->config({ %some_value }); 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 for more info. =head3 C my $merge = $source->merge; $source->config( $bool ); Chaining getter/setter for the flag that dictates whether STDOUT and STDERR should be merged (where appropriate). Defaults to undef. =head3 C my $switches = $source->switches; $source->config([ @switches ]); Chaining getter/setter for the list of command-line switches that should be passed to the source (where appropriate). Defaults to undef. =head3 C my $test_args = $source->test_args; $source->config([ @test_args ]); 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 @_; $self->{merge} = shift; return $self; } sub switches { my $self = shift; return $self->{switches} unless @_; $self->{switches} = shift; return $self; } sub test_args { my $self = shift; return $self->{test_args} unless @_; $self->{test_args} = shift; return $self; } =head3 C my $meta = $source->assemble_meta; Gathers meta data about the L source, stashes it in L and returns it as a hashref. This is done so that the Ls 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, } # for arrays: size => $n, =cut sub assemble_meta { my ($self) = @_; return $self->meta if $self->has_meta; my $meta = $self->meta; my $raw = $self->raw; # 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->{is_dir} && $file->{read} ) { eval { $file->{shebang} = $self->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 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; sub _read_shebang { my ( $class, $file ) = @_; open my $fh, '<', $file or die "Can't read $file: $!\n"; # Might be a binary file - so read a fixed number of bytes. my $got = read $fh, my ($buf), BLK_SIZE; defined $got or die "I/O error: $!\n"; return $1 if $buf =~ /(.*)/; return; } sub shebang { my ( $class, $file ) = @_; $shebang_for{$file} = $class->_read_shebang($file) unless exists $shebang_for{$file}; return $shebang_for{$file}; } } =head3 C my $config = $source->config_for( $class ); Returns L 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' ); 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, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/Iterator.pm0000644000175000017500000000566612640746046017244 0ustar leonleonpackage TAP::Parser::Iterator; use strict; use warnings; use base 'TAP::Object'; =head1 NAME TAP::Parser::Iterator - Base class for TAP source iterators =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS # to subclass: use TAP::Parser::Iterator (); use base 'TAP::Parser::Iterator'; sub _initialize { # see TAP::Object... } sub next_raw { ... } sub wait { ... } sub exit { ... } =head1 DESCRIPTION This is a simple iterator base class that defines L's iterator API. Iterators are typically created from Ls. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Provided by L. =head2 Instance Methods =head3 C while ( my $item = $iter->next ) { ... } Iterate through it, of course. =head3 C B this method is abstract and should be overridden. while ( my $item = $iter->next_raw ) { ... } Iterate raw input without applying any fixes for quirky input syntax. =cut sub next { my $self = shift; my $line = $self->next_raw; # vms nit: When encountering 'not ok', vms often has the 'not' on a line # by itself: # not # ok 1 - 'I hate VMS' if ( defined($line) and $line =~ /^\s*not\s*$/ ) { $line .= ( $self->next_raw || '' ); } return $line; } sub next_raw { require Carp; my $msg = Carp::longmess('abstract method called directly!'); $_[0]->_croak($msg); } =head3 C If necessary switch the input stream to handle unicode. This only has any effect for I/O handle based streams. The default implementation does nothing. =cut sub handle_unicode { } =head3 C Return a list of filehandles that may be used upstream in a select() call to signal that this Iterator is ready. Iterators that are not handle-based should return an empty list. The default implementation does nothing. =cut sub get_select_handles { return; } =head3 C B this method is abstract and should be overridden. my $wait_status = $iter->wait; Return the C status for this iterator. =head3 C B this method is abstract and should be overridden. my $wait_status = $iter->exit; Return the C status for this iterator. =cut sub wait { require Carp; my $msg = Carp::longmess('abstract method called directly!'); $_[0]->_croak($msg); } sub exit { require Carp; my $msg = Carp::longmess('abstract method called directly!'); $_[0]->_croak($msg); } 1; =head1 SUBCLASSING Please see L for a subclassing overview. You must override the abstract methods as noted above. =head2 Example L is probably the easiest example to follow. There's not much point repeating it here. =head1 SEE ALSO L, L, L, L, L, =cut Test-Harness-3.36/lib/TAP/Parser/Scheduler/0000755000175000017500000000000012640746441017015 5ustar leonleonTest-Harness-3.36/lib/TAP/Parser/Scheduler/Spinner.pm0000644000175000017500000000173612640746046021001 0ustar leonleonpackage TAP::Parser::Scheduler::Spinner; use strict; use warnings; use Carp; =head1 NAME TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Scheduler::Spinner; =head1 DESCRIPTION A no-op job. Returned by C as an instruction to the harness to spin (keep executing tests) while the scheduler can't return a real job. =head1 METHODS =head2 Class Methods =head3 C my $job = TAP::Parser::Scheduler::Spinner->new; Ignores any arguments and returns a new C object. =cut sub new { bless {}, shift } =head2 Instance Methods =head3 C Returns true indicating that is a 'spinner' job. Spinners are returned when the scheduler still has pending jobs but can't (because of locking) return one right now. =cut sub is_spinner {1} =head1 SEE ALSO L, L =cut 1; Test-Harness-3.36/lib/TAP/Parser/Scheduler/Job.pm0000644000175000017500000000423112640746046020066 0ustar leonleonpackage TAP::Parser::Scheduler::Job; use strict; use warnings; use Carp; =head1 NAME TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Scheduler::Job; =head1 DESCRIPTION Represents a single test 'job'. =head1 METHODS =head2 Class Methods =head3 C my $job = TAP::Parser::Scheduler::Job->new( $filename, $description ); Given the filename and description of a test as scalars, returns a new L object. =cut sub new { my ( $class, $name, $desc, @ctx ) = @_; return bless { filename => $name, description => $desc, @ctx ? ( context => \@ctx ) : (), }, $class; } =head2 Instance Methods =head3 C $self->on_finish(\&method). Register a closure to be called when this job is destroyed. The callback will be passed the C object as it's only argument. =cut sub on_finish { my ( $self, $cb ) = @_; $self->{on_finish} = $cb; } =head3 C $self->finish; Called when a job is complete to unlock it. If a callback has been registered with C, it calls it. Otherwise, it does nothing. =cut sub finish { my $self = shift; if ( my $cb = $self->{on_finish} ) { $cb->($self); } } =head2 Attributes $self->filename; $self->description; $self->context; These are all "getters" which return the data set for these attributes during object construction. =head3 C =head3 C =head3 C =cut sub filename { shift->{filename} } sub description { shift->{description} } sub context { @{ shift->{context} || [] } } =head3 C For backwards compatibility in callbacks. =cut sub as_array_ref { my $self = shift; return [ $self->filename, $self->description, $self->{context} ||= [] ]; } =head3 C $self->is_spinner; Returns false indicating that this is a real job rather than a 'spinner'. Spinners are returned when the scheduler still has pending jobs but can't (because of locking) return one right now. =cut sub is_spinner {0} 1; Test-Harness-3.36/lib/TAP/Parser/Grammar.pm0000644000175000017500000003645712640746046017043 0ustar leonleonpackage TAP::Parser::Grammar; use strict; use warnings; use TAP::Parser::ResultFactory (); use TAP::Parser::YAMLish::Reader (); use base 'TAP::Object'; =head1 NAME TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Grammar; my $grammar = $self->make_grammar({ iterator => $tap_parser_iterator, parser => $tap_parser, version => 12, }); my $result = $grammar->tokenize; =head1 DESCRIPTION C tokenizes lines from a L and constructs L 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 expanded at some future date (plus, this stuff was really cluttering the parser). =head1 METHODS =head2 Class Methods =head3 C my $grammar = TAP::Parser::Grammar->new({ iterator => $iterator, parser => $parser, version => $version, }); Returns L grammar object that will parse the TAP stream from the specified iterator. Both C and C are required arguments. If C is not set it defaults to C<12> (see L for more details). =cut # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $args ) = @_; $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; } my %language_for; { # XXX the 'not' and 'ok' might be on separate lines in VMS ... my $ok = qr/(?:not )?ok\b/; my $num = qr/\d+/; my %v12 = ( version => { syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i, handler => sub { my ( $self, $line ) = @_; my $version = $1; return $self->_make_version_token( $line, $version, ); }, }, plan => { syntax => qr/^1\.\.(\d+)\s*(.*)\z/, handler => sub { my ( $self, $line ) = @_; my ( $tests_planned, $tail ) = ( $1, $2 ); my $explanation = undef; my $skip = ''; if ( $tail =~ /^todo((?:\s+\d+)+)/ ) { my @todo = split /\s+/, _trim($1); return $self->_make_plan_token( $line, $tests_planned, 'TODO', '', \@todo ); } elsif ( 0 == $tests_planned ) { $skip = 'SKIP'; # If we can't match # SKIP the directive should be undef. ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i; } elsif ( $tail !~ /^\s*$/ ) { return $self->_make_unknown_token($line); } $explanation = '' unless defined $explanation; return $self->_make_plan_token( $line, $tests_planned, $skip, $explanation, [] ); }, }, # An optimization to handle the most common test lines without # directives. simple_test => { syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x, handler => sub { my ( $self, $line ) = @_; my ( $ok, $num, $desc ) = ( $1, $2, $3 ); return $self->_make_test_token( $line, $ok, $num, $desc ); }, }, test => { syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x, handler => sub { my ( $self, $line ) = @_; my ( $ok, $num, $desc ) = ( $1, $2, $3 ); my ( $dir, $explanation ) = ( '', '' ); if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* ) \# \s* (SKIP|TODO) \b \s* (.*) $/ix ) { ( $desc, $dir, $explanation ) = ( $1, $2, $3 ); } return $self->_make_test_token( $line, $ok, $num, $desc, $dir, $explanation ); }, }, comment => { syntax => qr/^#(.*)/, handler => sub { my ( $self, $line ) = @_; my $comment = $1; return $self->_make_comment_token( $line, $comment ); }, }, bailout => { syntax => qr/^\s*Bail out!\s*(.*)/, handler => sub { my ( $self, $line ) = @_; my $explanation = $1; return $self->_make_bailout_token( $line, $explanation ); }, }, ); my %v13 = ( %v12, plan => { syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i, handler => sub { my ( $self, $line ) = @_; my ( $tests_planned, $explanation ) = ( $1, $2 ); my $skip = ( 0 == $tests_planned || defined $explanation ) ? 'SKIP' : ''; $explanation = '' unless defined $explanation; return $self->_make_plan_token( $line, $tests_planned, $skip, $explanation, [] ); }, }, yaml => { syntax => qr/^ (\s+) (---.*) $/x, handler => sub { my ( $self, $line ) = @_; my ( $pad, $marker ) = ( $1, $2 ); return $self->_make_yaml_token( $pad, $marker ); }, }, pragma => { syntax => qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x, handler => sub { my ( $self, $line ) = @_; my $pragmas = $1; return $self->_make_pragma_token( $line, $pragmas ); }, }, ); %language_for = ( '12' => { tokens => \%v12, }, '13' => { tokens => \%v13, setup => sub { shift->{iterator}->handle_unicode; }, }, ); } ############################################################################## =head2 Instance Methods =head3 C $grammar->set_version(13); Tell the grammar which TAP syntax version to support. The lowest supported version is 12. Although 'TAP version' isn't valid version 12 syntax it is accepted so that higher version numbers may be parsed. =cut sub set_version { my $self = shift; my $version = shift; if ( my $language = $language_for{$version} ) { $self->{version} = $version; $self->{tokens} = $language->{tokens}; if ( my $setup = $language->{setup} ) { $self->$setup(); } $self->_order_tokens; } else { require Carp; Carp::croak("Unsupported syntax version: $version"); } } # Optimization to put the most frequent tokens first. sub _order_tokens { my $self = shift; my %copy = %{ $self->{tokens} }; my @ordered_tokens = grep {defined} map { delete $copy{$_} } qw( simple_test test comment plan ); push @ordered_tokens, values %copy; $self->{ordered_tokens} = \@ordered_tokens; } ############################################################################## =head3 C my $token = $grammar->tokenize; This method will return a L object representing the current line of TAP. =cut sub tokenize { my $self = shift; my $line = $self->{iterator}->next; unless ( defined $line ) { delete $self->{parser}; # break circular ref return; } my $token; for my $token_data ( @{ $self->{ordered_tokens} } ) { if ( $line =~ $token_data->{syntax} ) { my $handler = $token_data->{handler}; $token = $self->$handler($line); last; } } $token = $self->_make_unknown_token($line) unless $token; return $self->{parser}->make_result($token); } ############################################################################## =head3 C my @types = $grammar->token_types; Returns the different types of tokens which this grammar can parse. =cut sub token_types { my $self = shift; return keys %{ $self->{tokens} }; } ############################################################################## =head3 C my $syntax = $grammar->syntax_for($token_type); Returns a pre-compiled regular expression which will match a chunk of TAP corresponding to the token type. For example (not that you should really pay attention to this, C<< $grammar->syntax_for('comment') >> will return C<< qr/^#(.*)/ >>. =cut sub syntax_for { my ( $self, $type ) = @_; return $self->{tokens}->{$type}->{syntax}; } ############################################################################## =head3 C my $handler = $grammar->handler_for($token_type); Returns a code reference which, when passed an appropriate line of TAP, returns the lexed token corresponding to that line. As a result, the basic 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 ) ) { for my $type ( $grammar->token_types ) { my $syntax = $grammar->syntax_for($type); if ( $line =~ $syntax ) { my $handler = $grammar->handler_for($type); push @tokens => $grammar->$handler($line); next LINE; } } push @tokens => $grammar->_make_unknown_token($line); } =cut sub handler_for { my ( $self, $type ) = @_; return $self->{tokens}->{$type}->{handler}; } sub _make_version_token { my ( $self, $line, $version ) = @_; return { type => 'version', raw => $line, version => $version, }; } sub _make_plan_token { my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_; if ( $directive eq 'SKIP' && 0 != $tests_planned && $self->{version} < 13 ) { warn "Specified SKIP directive in plan but more than 0 tests ($line)\n"; } return { type => 'plan', raw => $line, tests_planned => $tests_planned, directive => $directive, explanation => _trim($explanation), todo_list => $todo, }; } sub _make_test_token { my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_; return { ok => $ok, # forcing this to be an integer (and not a string) reduces memory # consumption. RT #84939 test_num => ( defined $num ? 0 + $num : undef ), description => _trim($desc), directive => ( defined $dir ? uc $dir : '' ), explanation => _trim($explanation), raw => $line, type => 'test', }; } sub _make_unknown_token { my ( $self, $line ) = @_; return { raw => $line, type => 'unknown', }; } sub _make_comment_token { my ( $self, $line, $comment ) = @_; return { type => 'comment', raw => $line, comment => _trim($comment) }; } sub _make_bailout_token { my ( $self, $line, $explanation ) = @_; return { type => 'bailout', raw => $line, bailout => _trim($explanation) }; } sub _make_yaml_token { my ( $self, $pad, $marker ) = @_; my $yaml = TAP::Parser::YAMLish::Reader->new; my $iterator = $self->{iterator}; # Construct a reader that reads from our input stripping leading # spaces from each line. my $leader = length($pad); my $strip = qr{ ^ (\s{$leader}) (.*) $ }x; my @extra = ($marker); my $reader = sub { return shift @extra if @extra; my $line = $iterator->next; return $2 if $line =~ $strip; return; }; my $data = $yaml->read($reader); # Reconstitute input. This is convoluted. Maybe we should just # record it on the way in... chomp( my $raw = $yaml->get_raw ); $raw =~ s/^/$pad/mg; return { type => 'yaml', raw => $raw, data => $data }; } sub _make_pragma_token { my ( $self, $line, $pragmas ) = @_; return { type => 'pragma', raw => $line, pragmas => [ split /\s*,\s*/, _trim($pragmas) ], }; } sub _trim { my $data = shift; return '' unless defined $data; $data =~ s/^\s+//; $data =~ s/\s+$//; return $data; } 1; =head1 TAP GRAMMAR B This grammar is slightly out of date. There's still some discussion about it and a new one will be provided when we have things better defined. The L does not use a formal grammar because TAP is essentially a stream-based protocol. In fact, it's quite legal to have an infinite stream. For the same reason that we don't apply regexes to streams, we're not using a formal grammar here. Instead, we parse the TAP in lines. For purposes for forward compatibility, any result which does not match the following grammar is currently referred to as L. It is I a parse error. A formal grammar would look similar to the following: (* For the time being, I'm cheating on the EBNF by allowing certain terms to be defined by POSIX character classes by using the following syntax: digit ::= [:digit:] As far as I am aware, that's not valid EBNF. Sue me. I didn't know how to write "char" otherwise (Unicode issues). Suggestions welcome. *) tap ::= version? { comment | unknown } leading_plan lines | lines trailing_plan {comment} version ::= 'TAP version ' positiveInteger {positiveInteger} "\n" leading_plan ::= plan skip_directive? "\n" trailing_plan ::= plan "\n" plan ::= '1..' nonNegativeInteger lines ::= line {line} line ::= (comment | test | unknown | bailout ) "\n" test ::= status positiveInteger? description? directive? status ::= 'not '? 'ok ' description ::= (character - (digit | '#')) {character - '#'} directive ::= todo_directive | skip_directive todo_directive ::= hash_mark 'TODO' ' ' {character} skip_directive ::= hash_mark 'SKIP' ' ' {character} comment ::= hash_mark {character} hash_mark ::= '#' {' '} bailout ::= 'Bail out!' {character} unknown ::= { (character - "\n") } (* POSIX character classes and other terminals *) digit ::= [:digit:] character ::= ([:print:] - "\n") positiveInteger ::= ( digit - '0' ) {digit} nonNegativeInteger ::= digit {digit} =head1 SUBCLASSING Please see L for a subclassing overview. If you I want to subclass L's grammar the best thing to do is read through the code. There's no easy way of summarizing it here. =head1 SEE ALSO L, L, L, L, =cut Test-Harness-3.36/lib/TAP/Parser/SourceHandler/0000755000175000017500000000000012640746441017635 5ustar leonleonTest-Harness-3.36/lib/TAP/Parser/SourceHandler/Executable.pm0000644000175000017500000000771512640746046022267 0ustar leonleonpackage TAP::Parser::SourceHandler::Executable; use strict; use warnings; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Process (); use base '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.36 =cut our $VERSION = '3.36'; =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 L - it has 2 jobs: 1. Figure out if the L it's given is an executable command (L). 2. Creates an iterator for executable commands (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C 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 .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}; return 0.85 if $file->{execute} && $file->{binary}; return 0.8 if $file->{lc_ext} eq '.bat'; return 0.25 if $file->{execute}; } elsif ( $meta->{is_hash} ) { return 0.9 if $src->raw->{exec}; } return 0; } =head3 C my $iterator = $class->make_iterator( $source ); Returns a new L for the source. C<$source-Eraw> must be in one of the following forms: { exec => [ @exec ] } [ @exec ] $file Cs 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 ); push @command, @{ $source->test_args || [] }; return $class->iterator_class->new( { command => \@command, merge => $source->merge } ); } =head3 C The class of iterator to use, override if you're sub-classing. Defaults to L. =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 for a subclassing overview. =head2 Example package MyRubySourceHandler; use strict; use Carp qw( croak ); use TAP::Parser::SourceHandler::Executable; use base '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, L, L, L, L, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/SourceHandler/Perl.pm0000644000175000017500000002234712640746046021106 0ustar leonleonpackage TAP::Parser::SourceHandler::Perl; use strict; use warnings; use Config; use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant IS_VMS => ( $^O eq 'VMS' ); use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Process (); use Text::ParseWords qw(shellwords); use base '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.36 =cut our $VERSION = '3.36'; =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 L - it has 2 jobs: 1. Figure out if the L it's given is actually a Perl script (L). 2. Creates an iterator for Perl sources (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C 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.75 if it has any shebang 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/; # We favour Perl as the interpreter for any shebang to preserve # previous semantics: we used to execute everything via Perl and # relied on it to pass the shebang off to the appropriate # interpreter. return 0.3; } 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 my $iterator = $class->make_iterator( $source ); Constructs & returns a new L for the source. Assumes C<$source-Eraw> contains a reference to the perl script. Cs 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. The command generated is guaranteed to preserve: PERL5LIB PERL5OPT Taint Mode, if set in the script's shebang I the command generated will I 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 _autoflush_stdhandles { my ($class) = @_; $class->_autoflush( \*STDOUT ); $class->_autoflush( \*STDERR ); } 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_stdhandles; my ( $libs, $switches ) = $class->_mangle_switches( $class->_filter_libs( $class->_switches($source) ) ); $class->_run( $source, $libs, $switches ); } sub _has_taint_switch { my( $class, $switches ) = @_; my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches}; return $has_taint ? 1 : 0; } sub _mangle_switches { my ( $class, $libs, $switches ) = @_; # 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 ( $class->_has_taint_switch($switches) ) { my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : (); return ( $libs, [ @{$switches}, $class->_libs2switches([@$libs, @perl5lib]), defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : () ], ); } return ( $libs, $switches ); } sub _filter_libs { my ( $class, @switches ) = @_; 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/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { push @libs, $1; } else { push @filtered_switches, $_; } } return \@libs, \@filtered_switches; } sub _iterator_hooks { my ( $class, $source, $libs, $switches ) = @_; my $setup = sub { if ( @{$libs} and !$class->_has_taint_switch($switches) ) { $ENV{PERL5LIB} = join( $Config{path_sep}, grep {defined} @{$libs}, $ENV{PERL5LIB} ); } }; # VMS environment variables aren't guaranteed to reset at the end of # the process, so we need to put PERL5LIB back. my $previous = $ENV{PERL5LIB}; my $teardown = sub { if ( defined $previous ) { $ENV{PERL5LIB} = $previous; } else { delete $ENV{PERL5LIB}; } }; return ( $setup, $teardown ); } sub _run { my ( $class, $source, $libs, $switches ) = @_; my @command = $class->_get_command_for_switches( $source, $switches ) or $class->_croak("No command found!"); my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches ); return $class->_create_iterator( $source, \@command, $setup, $teardown ); } sub _create_iterator { my ( $class, $source, $command, $setup, $teardown ) = @_; 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 {$_} @{ $_[0] }; } =head3 C 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 @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 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 qq["$^X"] if IS_WIN32 && ( $^X =~ /[^\w\.\/\\]/ ); return $^X; } 1; __END__ =head1 SUBCLASSING Please see L for a subclassing overview. =head2 Example package MyPerlSourceHandler; use strict; use TAP::Parser::SourceHandler::Perl; use base '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, L, L, L, L, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/SourceHandler/File.pm0000644000175000017500000000557012640746046021062 0ustar leonleonpackage TAP::Parser::SourceHandler::File; use strict; use warnings; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Stream (); use base '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.36 =cut our $VERSION = '3.36'; =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 L - it has 2 jobs: 1. Figure out if the I source it's given is a file containing raw TAP output. See L 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, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C 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 my $iterator = $class->make_iterator( $source ); Returns a new L for the source. Cs 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 The class of iterator to use, override if you're sub-classing. Defaults to L. =cut use constant iterator_class => 'TAP::Parser::Iterator::Stream'; 1; __END__ =head1 CONFIGURATION { extensions => [ @case_insensitive_exts_to_match ] } =head1 SUBCLASSING Please see L for a subclassing overview. =head1 SEE ALSO L, L, L, L, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/SourceHandler/Handle.pm0000644000175000017500000000513312640746046021371 0ustar leonleonpackage TAP::Parser::SourceHandler::Handle; use strict; use warnings; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Stream (); use base '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.36 =cut our $VERSION = '3.36'; =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 L class. It has 2 jobs: 1. Figure out if the L it's given is an L or GLOB containing raw TAP output (L). 2. Creates an iterator for IO::Handle's & globs (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C 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 my $iterator = $class->make_iterator( $source ); Returns a new L 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 The class of iterator to use, override if you're sub-classing. Defaults to L. =cut use constant iterator_class => 'TAP::Parser::Iterator::Stream'; 1; =head1 SUBCLASSING Please see L for a subclassing overview. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/SourceHandler/RawTAP.pm0000644000175000017500000000543212640746046021276 0ustar leonleonpackage TAP::Parser::SourceHandler::RawTAP; use strict; use warnings; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Array (); use base '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.36 =cut our $VERSION = '3.36'; =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 L - it has 2 jobs: 1. Figure out if the L it's given is raw TAP output (L). 2. Creates an iterator for raw TAP output (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C 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 my $iterator = $class->make_iterator( $source ); Returns a new L for the source. C<$source-Eraw> must be an array ref, or a scalar ref. Cs 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 for a subclassing overview. =head1 SEE ALSO L, L, L, L, L, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/Result.pm0000644000175000017500000001400112640746046016710 0ustar leonleonpackage TAP::Parser::Result; use strict; use warnings; use base 'TAP::Object'; BEGIN { # make is_* methods my @attrs = qw( plan pragma test comment bailout version unknown yaml ); no strict 'refs'; for my $token (@attrs) { my $method = "is_$token"; *$method = sub { return $token eq shift->type }; } } ############################################################################## =head1 NAME TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS # abstract class - not meant to be used directly # see TAP::Parser::ResultFactory for preferred usage # directly: use TAP::Parser::Result; my $token = {...}; my $result = TAP::Parser::Result->new( $token ); =head2 DESCRIPTION This is a simple base class used by L to store objects that represent the current bit of test output data from TAP (usually a single line). Unless you're subclassing, you probably won't need to use this module directly. =head2 METHODS =head3 C # see TAP::Parser::ResultFactory for preferred usage # to use directly: my $result = TAP::Parser::Result->new($token); Returns an instance the appropriate class for the test token passed in. =cut # new() implementation provided by TAP::Object sub _initialize { my ( $self, $token ) = @_; if ($token) { # assign to a hash slice to make a shallow copy of the token. # I guess we could assign to the hash as (by default) there are not # contents, but that seems less helpful if someone wants to subclass us @{$self}{ keys %$token } = values %$token; } return $self; } ############################################################################## =head2 Boolean methods The following methods all return a boolean value and are to be overridden in the appropriate subclass. =over 4 =item * C Indicates whether or not this is the test plan line. 1..3 =item * C Indicates whether or not this is a pragma line. pragma +strict =item * C Indicates whether or not this is a test line. ok 1 Is OK! =item * C Indicates whether or not this is a comment. # this is a comment =item * C Indicates whether or not this is bailout line. Bail out! We're out of dilithium crystals. =item * C Indicates whether or not this is a TAP version line. TAP version 4 =item * C Indicates whether or not the current line could be parsed. ... this line is junk ... =item * C Indicates whether or not this is a YAML chunk. =back =cut ############################################################################## =head3 C print $result->raw; Returns the original line of text which was parsed. =cut sub raw { shift->{raw} } ############################################################################## =head3 C my $type = $result->type; Returns the "type" of a token, such as C or C. =cut sub type { shift->{type} } ############################################################################## =head3 C print $result->as_string; Prints a string representation of the token. This might not be the exact output, however. Tests will have test numbers added if not present, TODO and SKIP directives will be capitalized and, in general, things will be cleaned up. If you need the original text for the token, see the C method. =cut sub as_string { shift->{raw} } ############################################################################## =head3 C if ( $result->is_ok ) { ... } Reports whether or not a given result has passed. Anything which is B a test result returns true. This is merely provided as a convenient shortcut. =cut sub is_ok {1} ############################################################################## =head3 C Deprecated. Please use C instead. =cut sub passed { warn 'passed() is deprecated. Please use "is_ok()"'; shift->is_ok; } ############################################################################## =head3 C if ( $result->has_directive ) { ... } Indicates whether or not the given result has a TODO or SKIP directive. =cut sub has_directive { my $self = shift; return ( $self->has_todo || $self->has_skip ); } ############################################################################## =head3 C if ( $result->has_todo ) { ... } Indicates whether or not the given result has a TODO directive. =cut sub has_todo { 'TODO' eq ( shift->{directive} || '' ) } ############################################################################## =head3 C if ( $result->has_skip ) { ... } Indicates whether or not the given result has a SKIP directive. =cut sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) } =head3 C Set the directive associated with this token. Used internally to fake TODO tests. =cut sub set_directive { my ( $self, $dir ) = @_; $self->{directive} = $dir; } 1; =head1 SUBCLASSING Please see L for a subclassing overview. Remember: if you want your subclass to be automatically used by the parser, you'll have to register it with L. If you're creating a completely new result I, you'll probably need to subclass L too, or else it'll never get used. =head2 Example package MyResult; use strict; use base 'TAP::Parser::Result'; # register with the factory: TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); sub as_string { 'My results all look the same' } =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =cut Test-Harness-3.36/lib/TAP/Parser/Iterator/0000755000175000017500000000000012640746441016670 5ustar leonleonTest-Harness-3.36/lib/TAP/Parser/Iterator/Stream.pm0000644000175000017500000000326412640746046020467 0ustar leonleonpackage TAP::Parser::Iterator::Stream; use strict; use warnings; use base 'TAP::Parser::Iterator'; =head1 NAME TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Iterator::Stream; open( TEST, 'test.tap' ); my $it = TAP::Parser::Iterator::Stream->new(\*TEST); my $line = $it->next; =head1 DESCRIPTION This is a simple iterator wrapper for reading from filehandles, used by L. Unless you're writing a plugin or subclassing, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Expects one argument containing a filehandle. =cut # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $thing ) = @_; $self->{fh} = $thing; return $self; } =head2 Instance Methods =head3 C Iterate through it, of course. =head3 C Iterate raw input without applying any fixes for quirky input syntax. =head3 C Get the wait status for this iterator. Always returns zero. =head3 C Get the exit status for this iterator. Always returns zero. =cut sub wait { shift->exit } sub exit { shift->{fh} ? () : 0 } sub next_raw { my $self = shift; my $fh = $self->{fh}; if ( defined( my $line = <$fh> ) ) { chomp $line; return $line; } else { $self->_finish; return; } } sub _finish { my $self = shift; close delete $self->{fh}; } 1; =head1 ATTRIBUTION Originally ripped off from L. =head1 SEE ALSO L, L, L, =cut Test-Harness-3.36/lib/TAP/Parser/Iterator/Process.pm0000644000175000017500000002163412640746046020653 0ustar leonleonpackage TAP::Parser::Iterator::Process; use strict; use warnings; use Config; use IO::Handle; use base 'TAP::Parser::Iterator'; my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); =head1 NAME TAP::Parser::Iterator::Process - Iterator for process-based TAP sources =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Iterator::Process; my %args = ( command => ['python', 'setup.py', 'test'], merge => 1, setup => sub { ... }, teardown => sub { ... }, ); my $it = TAP::Parser::Iterator::Process->new(\%args); my $line = $it->next; =head1 DESCRIPTION This is a simple iterator wrapper for executing external processes, used by L. Unless you're writing a plugin or subclassing, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Expects one argument containing a hashref of the form: command => \@command_to_execute merge => $attempt_merge_stderr_and_stdout? setup => $callback_to_setup_command teardown => $callback_to_teardown_command Tries to uses L & L to communicate with the spawned process if they are available. Falls back onto C. =head2 Instance Methods =head3 C Iterate through the process output, of course. =head3 C Iterate raw input without applying any fixes for quirky input syntax. =head3 C Get the wait status for this iterator's process. =head3 C Get the exit status for this iterator's process. =cut { no warnings 'uninitialized'; # 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 { my $self = shift; return unless $Config{d_fork} || $IS_WIN32; for my $module (qw( IPC::Open3 IO::Select )) { eval "use $module"; return if $@; } return 1; } { my $got_unicode; sub _get_unicode { return $got_unicode if defined $got_unicode; eval 'use Encode qw(decode_utf8);'; $got_unicode = $@ ? 0 : 1; } } # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $args ) = @_; 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; my $merge = delete $args->{merge}; my ( $pid, $err, $sel ); if ( my $setup = delete $args->{setup} ) { $setup->(@command); } my $out = IO::Handle->new; if ( $self->_use_open3 ) { # HOTPATCH {{{ my $xclose = \&IPC::Open3::xclose; no warnings; local *IPC::Open3::xclose = sub { my $fh = shift; no strict 'refs'; return if ( fileno($fh) == fileno(STDIN) ); $xclose->($fh); }; # }}} if ($IS_WIN32) { $err = $merge ? '' : '>&STDERR'; eval { $pid = open3( '<&STDIN', $out, $merge ? '' : $err, @command ); }; die "Could not execute (@command): $@" if $@; if ( $] >= 5.006 ) { binmode($out, ":crlf"); } } else { $err = $merge ? '' : IO::Handle->new; eval { $pid = open3( '<&STDIN', $out, $err, @command ); }; die "Could not execute (@command): $@" if $@; $sel = $merge ? undef : IO::Select->new( $out, $err ); } } else { $err = ''; my $command = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command ); open( $out, "$command|" ) or die "Could not execute ($command): $!"; } $self->{out} = $out; $self->{err} = $err; $self->{sel} = $sel; $self->{pid} = $pid; $self->{exit} = undef; $self->{chunk_size} = $chunk_size; if ( my $teardown = delete $args->{teardown} ) { $self->{teardown} = sub { $teardown->(@command); }; } return $self; } =head3 C Upgrade the input stream to handle UTF8. =cut sub handle_unicode { my $self = shift; if ( $self->{sel} ) { if ( _get_unicode() ) { # Make sure our iterator has been constructed and... my $next = $self->{_next} ||= $self->_next; # ...wrap it to do UTF8 casting $self->{_next} = sub { my $line = $next->(); return decode_utf8($line) if defined $line; return; }; } } else { if ( $] >= 5.008 ) { eval 'binmode($self->{out}, ":utf8")'; } } } ############################################################################## sub wait { shift->{wait} } sub exit { shift->{exit} } sub _next { my $self = shift; if ( my $out = $self->{out} ) { if ( my $sel = $self->{sel} ) { my $err = $self->{err}; my @buf = (); my $partial = ''; # Partial line my $chunk_size = $self->{chunk_size}; return sub { return shift @buf if @buf; READ: while ( my @ready = $sel->can_read ) { for my $fh (@ready) { my $got = sysread $fh, my ($chunk), $chunk_size; if ( $got == 0 ) { $sel->remove($fh); } elsif ( $fh == $err ) { print STDERR $chunk; # echo STDERR } else { $chunk = $partial . $chunk; $partial = ''; # Make sure we have a complete line unless ( substr( $chunk, -1, 1 ) eq "\n" ) { my $nl = rindex $chunk, "\n"; if ( $nl == -1 ) { $partial = $chunk; redo READ; } else { $partial = substr( $chunk, $nl + 1 ); $chunk = substr( $chunk, 0, $nl ); } } push @buf, split /\n/, $chunk; return shift @buf if @buf; } } } # Return partial last line if ( length $partial ) { my $last = $partial; $partial = ''; return $last; } $self->_finish; return; }; } else { return sub { if ( defined( my $line = <$out> ) ) { chomp $line; return $line; } $self->_finish; return; }; } } else { return sub { $self->_finish; return; }; } } sub next_raw { my $self = shift; return ( $self->{_next} ||= $self->_next )->(); } sub _finish { my $self = shift; my $status = $?; # Avoid circular refs $self->{_next} = sub {return} if $] >= 5.006; # If we have a subprocess we need to wait for it to terminate if ( defined $self->{pid} ) { if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) { $status = $?; } } ( delete $self->{out} )->close if $self->{out}; # If we have an IO::Select we also have an error handle to close. if ( $self->{sel} ) { ( delete $self->{err} )->close; delete $self->{sel}; } else { $status = $?; } # Sometimes we get -1 on Windows. Presumably that means status not # available. $status = 0 if $IS_WIN32 && $status == -1; $self->{wait} = $status; $self->{exit} = $self->_wait2exit($status); if ( my $teardown = $self->{teardown} ) { $teardown->(); } return $self; } =head3 C Return a list of filehandles that may be used upstream in a select() call to signal that this Iterator is ready. Iterators that are not handle based should return an empty list. =cut sub get_select_handles { my $self = shift; return grep $_, ( $self->{out}, $self->{err} ); } 1; =head1 ATTRIBUTION Originally ripped off from L. =head1 SEE ALSO L, L, L, =cut Test-Harness-3.36/lib/TAP/Parser/Iterator/Array.pm0000644000175000017500000000324012640746046020304 0ustar leonleonpackage TAP::Parser::Iterator::Array; use strict; use warnings; use base 'TAP::Parser::Iterator'; =head1 NAME TAP::Parser::Iterator::Array - Iterator for array-based TAP sources =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Iterator::Array; my @data = ('foo', 'bar', baz'); my $it = TAP::Parser::Iterator::Array->new(\@data); my $line = $it->next; =head1 DESCRIPTION This is a simple iterator wrapper for arrays of scalar content, used by L. Unless you're writing a plugin or subclassing, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Takes one argument: an C<$array_ref> =head2 Instance Methods =head3 C Iterate through it, of course. =head3 C Iterate raw input without applying any fixes for quirky input syntax. =head3 C Get the wait status for this iterator. For an array iterator this will always be zero. =head3 C Get the exit status for this iterator. For an array iterator this will always be zero. =cut # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $thing ) = @_; chomp @$thing; $self->{idx} = 0; $self->{array} = $thing; $self->{exit} = undef; return $self; } sub wait { shift->exit } sub exit { my $self = shift; return 0 if $self->{idx} >= @{ $self->{array} }; return; } sub next_raw { my $self = shift; return $self->{array}->[ $self->{idx}++ ]; } 1; =head1 ATTRIBUTION Originally ripped off from L. =head1 SEE ALSO L, L, L, =cut Test-Harness-3.36/lib/TAP/Parser/YAMLish/0000755000175000017500000000000012640746441016345 5ustar leonleonTest-Harness-3.36/lib/TAP/Parser/YAMLish/Reader.pm0000644000175000017500000001666312640746046020122 0ustar leonleonpackage TAP::Parser::YAMLish::Reader; use strict; use warnings; use base 'TAP::Object'; our $VERSION = '3.36'; # TODO: # Handle blessed object syntax # Printable characters for escapes my %UNESCAPES = ( z => "\x00", a => "\x07", t => "\x09", n => "\x0a", v => "\x0b", f => "\x0c", r => "\x0d", e => "\x1b", '\\' => '\\', ); my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x; my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x; my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x; my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x; my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x; # new() implementation supplied by TAP::Object sub read { my $self = shift; my $obj = shift; die "Must have a code reference to read input from" unless ref $obj eq 'CODE'; $self->{reader} = $obj; $self->{capture} = []; # Prime the reader $self->_next; return unless $self->{next}; my $doc = $self->_read; # The terminator is mandatory otherwise we'd consume a line from the # iterator that doesn't belong to us. If we want to remove this # restriction we'll have to implement look-ahead in the iterators. # Which might not be a bad idea. my $dots = $self->_peek; die "Missing '...' at end of YAMLish" unless defined $dots and $dots =~ $IS_END_YAML; delete $self->{reader}; delete $self->{next}; return $doc; } sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" } sub _peek { my $self = shift; return $self->{next} unless wantarray; my $line = $self->{next}; $line =~ /^ (\s*) (.*) $ /x; return ( $2, length $1 ); } sub _next { my $self = shift; die "_next called with no reader" unless $self->{reader}; my $line = $self->{reader}->(); $self->{next} = $line; push @{ $self->{capture} }, $line; } sub _read { my $self = shift; my $line = $self->_peek; # Do we have a document header? if ( $line =~ /^ --- (?: \s* (.+?)? \s* )? $/x ) { $self->_next; return $self->_read_scalar($1) if defined $1; # Inline? my ( $next, $indent ) = $self->_peek; if ( $next =~ /^ - /x ) { return $self->_read_array($indent); } elsif ( $next =~ $IS_HASH_KEY ) { return $self->_read_hash( $next, $indent ); } elsif ( $next =~ $IS_END_YAML ) { die "Premature end of YAMLish"; } else { die "Unsupported YAMLish syntax: '$next'"; } } else { die "YAMLish document header not found"; } } # Parse a double quoted string sub _read_qq { my $self = shift; my $str = shift; unless ( $str =~ s/^ " (.*?) " $/$1/x ) { die "Internal: not a quoted string"; } $str =~ s/\\"/"/gx; $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex; return $str; } # Parse a scalar string to the actual scalar sub _read_scalar { my $self = shift; my $string = shift; return undef if $string eq '~'; return {} if $string eq '{}'; return [] if $string eq '[]'; if ( $string eq '>' || $string eq '|' ) { my ( $line, $indent ) = $self->_peek; die "Multi-line scalar content missing" unless defined $line; my @multiline = ($line); while (1) { $self->_next; my ( $next, $ind ) = $self->_peek; last if $ind < $indent; my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : ''; push @multiline, $pad . $next; } return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n"; } if ( $string =~ /^ ' (.*) ' $/x ) { ( my $rv = $1 ) =~ s/''/'/g; return $rv; } if ( $string =~ $IS_QQ_STRING ) { return $self->_read_qq($string); } if ( $string =~ /^['"]/ ) { # A quote with folding... we don't support that die __PACKAGE__ . " does not support multi-line quoted scalars"; } # Regular unquoted string return $string; } sub _read_nested { my $self = shift; my ( $line, $indent ) = $self->_peek; if ( $line =~ /^ -/x ) { return $self->_read_array($indent); } elsif ( $line =~ $IS_HASH_KEY ) { return $self->_read_hash( $line, $indent ); } else { die "Unsupported YAMLish syntax: '$line'"; } } # Parse an array sub _read_array { my ( $self, $limit ) = @_; my $ar = []; while (1) { my ( $line, $indent ) = $self->_peek; last if $indent < $limit || !defined $line || $line =~ $IS_END_YAML; if ( $indent > $limit ) { die "Array line over-indented"; } if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) { $indent += length $1; $line =~ s/-\s+//; push @$ar, $self->_read_hash( $line, $indent ); } elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) { die "Unexpected start of YAMLish" if $line =~ /^---/; $self->_next; push @$ar, $self->_read_scalar($1); } elsif ( $line =~ /^ - \s* $/x ) { $self->_next; push @$ar, $self->_read_nested; } elsif ( $line =~ $IS_HASH_KEY ) { $self->_next; push @$ar, $self->_read_hash( $line, $indent, ); } else { die "Unsupported YAMLish syntax: '$line'"; } } return $ar; } sub _read_hash { my ( $self, $line, $limit ) = @_; my $indent; my $hash = {}; while (1) { die "Badly formed hash line: '$line'" unless $line =~ $HASH_LINE; my ( $key, $value ) = ( $self->_read_scalar($1), $2 ); $self->_next; if ( defined $value ) { $hash->{$key} = $self->_read_scalar($value); } else { $hash->{$key} = $self->_read_nested; } ( $line, $indent ) = $self->_peek; last if $indent < $limit || !defined $line || $line =~ $IS_END_YAML; } return $hash; } 1; __END__ =pod =head1 NAME TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION Version 3.36 =head1 SYNOPSIS =head1 DESCRIPTION Note that parts of this code were derived from L with the permission of Adam Kennedy. =head1 METHODS =head2 Class Methods =head3 C The constructor C creates and returns an empty C object. my $reader = TAP::Parser::YAMLish::Reader->new; =head2 Instance Methods =head3 C my $got = $reader->read($iterator); Read YAMLish from a L and return the data structure it represents. =head3 C my $source = $reader->get_source; Return the raw YAMLish source from the most recent C. =head1 AUTHOR Andy Armstrong, Adam Kennedy wrote L which provided the template and many of the YAML matching regular expressions for this module. =head1 SEE ALSO L, L, L, L, L, L =head1 COPYRIGHT Copyright 2007-2011 Andy Armstrong. Portions copyright 2006-2008 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Test-Harness-3.36/lib/TAP/Parser/YAMLish/Writer.pm0000644000175000017500000001216312640746046020163 0ustar leonleonpackage TAP::Parser::YAMLish::Writer; use strict; use warnings; use base 'TAP::Object'; our $VERSION = '3.36'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; my @UNPRINTABLE = qw( z x01 x02 x03 x04 x05 x06 a x08 t n v f r x0e x0f x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1a e x1c x1d x1e x1f ); # new() implementation supplied by TAP::Object sub write { my $self = shift; die "Need something to write" unless @_; my $obj = shift; my $out = shift || \*STDOUT; die "Need a reference to something I can write to" unless ref $out; $self->{writer} = $self->_make_writer($out); $self->_write_obj( '---', $obj ); $self->_put('...'); delete $self->{writer}; } sub _make_writer { my $self = shift; my $out = shift; my $ref = ref $out; if ( 'CODE' eq $ref ) { return $out; } elsif ( 'ARRAY' eq $ref ) { return sub { push @$out, shift }; } elsif ( 'SCALAR' eq $ref ) { return sub { $$out .= shift() . "\n" }; } elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) { return sub { print $out shift(), "\n" }; } die "Can't write to $out"; } sub _put { my $self = shift; $self->{writer}->( join '', @_ ); } sub _enc_scalar { my $self = shift; my $val = shift; my $rule = shift; return '~' unless defined $val; if ( $val =~ /$rule/ ) { $val =~ s/\\/\\\\/g; $val =~ s/"/\\"/g; $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex; return qq{"$val"}; } if ( length($val) == 0 or $val =~ /\s/ ) { $val =~ s/'/''/; return "'$val'"; } return $val; } sub _write_obj { my $self = shift; my $prefix = shift; my $obj = shift; my $indent = shift || 0; if ( my $ref = ref $obj ) { my $pad = ' ' x $indent; if ( 'HASH' eq $ref ) { if ( keys %$obj ) { $self->_put($prefix); for my $key ( sort keys %$obj ) { my $value = $obj->{$key}; $self->_write_obj( $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':', $value, $indent + 1 ); } } else { $self->_put( $prefix, ' {}' ); } } elsif ( 'ARRAY' eq $ref ) { if (@$obj) { $self->_put($prefix); for my $value (@$obj) { $self->_write_obj( $pad . '-', $value, $indent + 1 ); } } else { $self->_put( $prefix, ' []' ); } } else { die "Don't know how to encode $ref"; } } else { $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) ); } } 1; __END__ =pod =head1 NAME TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION Version 3.36 =head1 SYNOPSIS use TAP::Parser::YAMLish::Writer; my $data = { one => 1, two => 2, three => [ 1, 2, 3 ], }; my $yw = TAP::Parser::YAMLish::Writer->new; # Write to an array... $yw->write( $data, \@some_array ); # ...an open file handle... $yw->write( $data, $some_file_handle ); # ...a string ... $yw->write( $data, \$some_string ); # ...or a closure $yw->write( $data, sub { my $line = shift; print "$line\n"; } ); =head1 DESCRIPTION Encodes a scalar, hash reference or array reference as YAMLish. =head1 METHODS =head2 Class Methods =head3 C my $writer = TAP::Parser::YAMLish::Writer->new; The constructor C creates and returns an empty C object. =head2 Instance Methods =head3 C $writer->write($obj, $output ); Encode a scalar, hash reference or array reference as YAML. my $writer = sub { my $line = shift; print SOMEFILE "$line\n"; }; my $data = { one => 1, two => 2, three => [ 1, 2, 3 ], }; my $yw = TAP::Parser::YAMLish::Writer->new; $yw->write( $data, $writer ); The C< $output > argument may be: =over =item * a reference to a scalar to append YAML to =item * the handle of an open file =item * a reference to an array into which YAML will be pushed =item * a code reference =back If you supply a code reference the subroutine will be called once for each line of output with the line as its only argument. Passed lines will have no trailing newline. =head1 AUTHOR Andy Armstrong, =head1 SEE ALSO L, L, L, L, L, L =head1 COPYRIGHT Copyright 2007-2011 Andy Armstrong. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Test-Harness-3.36/lib/TAP/Parser/SourceHandler.pm0000644000175000017500000001204212640746046020173 0ustar leonleonpackage TAP::Parser::SourceHandler; use strict; use warnings; use TAP::Parser::Iterator (); use base 'TAP::Object'; =head1 NAME TAP::Parser::SourceHandler - Base class for different TAP source handlers =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =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 '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 handlers / handlers. A C does whatever is necessary to produce & capture a stream of TAP from the I source, and package it up in a L for the parser to consume. C must implement the I interface used by L. At 2 methods, the interface is pretty simple: L and L. Unless you're writing a new L, a plugin, or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C I. my $vote = $class->can_handle( $source ); C<$source> is a L. 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 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 I. my $iterator = $class->make_iterator( $source ); C<$source> is a L. Returns a new L object for use by the L. Cs 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 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 and L. L is the easiest sub-class to use as an example. It's important to point out that if you want your subclass to be automatically used by L you'll have to and make sure it gets loaded somehow. If you're using L you can write an L plugin. If you're using L or L directly (e.g. through a custom script, L, or L) you can use the C option which will cause L to load your subclass). Don't forget to register your class with L. =head2 Example package MySourceHandler; use strict; use MySourceHandler; # see TAP::Parser::SourceHandler use TAP::Parser::IteratorFactory; use base '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, L, L, L, L, L, L, L, L, L =cut Test-Harness-3.36/lib/TAP/Parser/Result/0000755000175000017500000000000012640746441016355 5ustar leonleonTest-Harness-3.36/lib/TAP/Parser/Result/Pragma.pm0000644000175000017500000000166212640746046020130 0ustar leonleonpackage TAP::Parser::Result::Pragma; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a pragma is encountered. TAP version 13 pragma +strict, -foo Pragmas are only supported from TAP version 13 onwards. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_pragma ) { @pragmas = $result->pragmas; } =cut sub pragmas { my @pragmas = @{ shift->{pragmas} }; return wantarray ? @pragmas : \@pragmas; } 1; Test-Harness-3.36/lib/TAP/Parser/Result/Bailout.pm0000644000175000017500000000217412640746046020317 0ustar leonleonpackage TAP::Parser::Result::Bailout; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a bail out line is encountered. 1..5 ok 1 - woo hooo! Bail out! Well, so much for "woo hooo!" =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_bailout ) { my $explanation = $result->explanation; print "We bailed out because ($explanation)"; } If, and only if, a token is a bailout token, you can get an "explanation" via this method. The explanation is the text after the mystical "Bail out!" words which appear in the tap output. =cut sub explanation { shift->{bailout} } sub as_string { shift->{bailout} } 1; Test-Harness-3.36/lib/TAP/Parser/Result/Test.pm0000644000175000017500000001367612640746046017650 0ustar leonleonpackage TAP::Parser::Result::Test; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Test - Test result token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a test line is encountered. 1..1 ok 1 - woo hooo! =head1 OVERRIDDEN METHODS This class is the workhorse of the L system. Most TAP lines will be test lines and if C<< $result->is_test >>, then you have a bunch of methods at your disposal. =head2 Instance Methods =cut ############################################################################## =head3 C my $ok = $result->ok; Returns the literal text of the C or C status. =cut sub ok { shift->{ok} } ############################################################################## =head3 C my $test_number = $result->number; Returns the number of the test, even if the original TAP output did not supply that number. =cut sub number { shift->{test_num} } sub _number { my ( $self, $number ) = @_; $self->{test_num} = $number; } ############################################################################## =head3 C my $description = $result->description; Returns the description of the test, if any. This is the portion after the test number but before the directive. =cut sub description { shift->{description} } ############################################################################## =head3 C my $directive = $result->directive; Returns either C or C if either directive was present for a test line. =cut sub directive { shift->{directive} } ############################################################################## =head3 C my $explanation = $result->explanation; If a test had either a C or C directive, this method will return the accompanying explanation, if present. not ok 17 - 'Pigs can fly' # TODO not enough acid For the above line, the explanation is I. =cut sub explanation { shift->{explanation} } ############################################################################## =head3 C if ( $result->is_ok ) { ... } Returns a boolean value indicating whether or not the test passed. Remember that for TODO tests, the test always passes. If the test is unplanned, this method will always return false. See C. =cut sub is_ok { my $self = shift; return if $self->is_unplanned; # TODO directives reverse the sense of a test. return $self->has_todo ? 1 : $self->ok !~ /not/; } ############################################################################## =head3 C if ( $result->is_actual_ok ) { ... } Returns a boolean value indicating whether or not the test passed, regardless of its TODO status. =cut sub is_actual_ok { my $self = shift; return $self->{ok} !~ /not/; } ############################################################################## =head3 C Deprecated. Please use C instead. =cut sub actual_passed { warn 'actual_passed() is deprecated. Please use "is_actual_ok()"'; goto &is_actual_ok; } ############################################################################## =head3 C if ( $test->todo_passed ) { # test unexpectedly succeeded } If this is a TODO test and an 'ok' line, this method returns true. Otherwise, it will always return false (regardless of passing status on non-todo tests). This is used to track which tests unexpectedly succeeded. =cut sub todo_passed { my $self = shift; return $self->has_todo && $self->is_actual_ok; } ############################################################################## =head3 C # deprecated in favor of 'todo_passed'. This method was horribly misnamed. This was a badly misnamed method. It indicates which TODO tests unexpectedly succeeded. Will now issue a warning and call C. =cut sub todo_failed { warn 'todo_failed() is deprecated. Please use "todo_passed()"'; goto &todo_passed; } ############################################################################## =head3 C if ( $result->has_skip ) { ... } Returns a boolean value indicating whether or not this test has a SKIP directive. =head3 C if ( $result->has_todo ) { ... } Returns a boolean value indicating whether or not this test has a TODO directive. =head3 C print $result->as_string; This method prints the test as a string. It will probably be similar, but not necessarily identical, to the original test line. Directives are capitalized, some whitespace may be trimmed and a test number will be added if it was not present in the original line. If you need the original text of the test line, use the C method. =cut sub as_string { my $self = shift; my $string = $self->ok . " " . $self->number; if ( my $description = $self->description ) { $string .= " $description"; } if ( my $directive = $self->directive ) { my $explanation = $self->explanation; $string .= " # $directive $explanation"; } return $string; } ############################################################################## =head3 C if ( $test->is_unplanned ) { ... } $test->is_unplanned(1); If a test number is greater than the number of planned tests, this method will return true. Unplanned tests will I return false for C, regardless of whether or not the test C. Note that if tests have a trailing plan, it is not possible to set this property for unplanned tests as we do not know it's unplanned until the plan is reached: print <<'END'; ok 1 ok 2 1..1 END =cut sub is_unplanned { my $self = shift; return ( $self->{unplanned} || '' ) unless @_; $self->{unplanned} = !!shift; return $self; } 1; Test-Harness-3.36/lib/TAP/Parser/Result/Unknown.pm0000644000175000017500000000133612640746046020356 0ustar leonleonpackage TAP::Parser::Result::Unknown; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if the parser does not recognize the token line. For example: 1..5 VERSION 7 ok 1 - woo hooo! ... woo hooo! is cool! In the above "TAP", the second and fourth lines will generate "Unknown" tokens. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut 1; Test-Harness-3.36/lib/TAP/Parser/Result/YAML.pm0000644000175000017500000000156012640746046017460 0ustar leonleonpackage TAP::Parser::Result::YAML; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::YAML - YAML result token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a YAML block is encountered. 1..1 ok 1 - woo hooo! C<1..1> is the plan. Gotta have a plan. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_yaml ) { print $result->data; } Return the parsed YAML data for this result =cut sub data { shift->{data} } 1; Test-Harness-3.36/lib/TAP/Parser/Result/Comment.pm0000644000175000017500000000173212640746046020321 0ustar leonleonpackage TAP::Parser::Result::Comment; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Comment - Comment result token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a comment line is encountered. 1..1 ok 1 - woo hooo! # this is a comment =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C Note that this method merely returns the comment preceded by a '# '. =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_comment ) { my $comment = $result->comment; print "I have something to say: $comment"; } =cut sub comment { shift->{comment} } sub as_string { shift->{raw} } 1; Test-Harness-3.36/lib/TAP/Parser/Result/Plan.pm0000644000175000017500000000400012640746046017600 0ustar leonleonpackage TAP::Parser::Result::Plan; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Plan - Plan result token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a plan line is encountered. 1..1 ok 1 - woo hooo! C<1..1> is the plan. Gotta have a plan. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_plan ) { print $result->plan; } This is merely a synonym for C. =cut sub plan { '1..' . shift->{tests_planned} } ############################################################################## =head3 C my $planned = $result->tests_planned; Returns the number of tests planned. For example, a plan of C<1..17> will cause this method to return '17'. =cut sub tests_planned { shift->{tests_planned} } ############################################################################## =head3 C my $directive = $plan->directive; If a SKIP directive is included with the plan, this method will return it. 1..0 # SKIP: why bother? =cut sub directive { shift->{directive} } ############################################################################## =head3 C if ( $result->has_skip ) { ... } Returns a boolean value indicating whether or not this test has a SKIP directive. =head3 C my $explanation = $plan->explanation; If a SKIP directive was included with the plan, this method will return the explanation, if any. =cut sub explanation { shift->{explanation} } =head3 C my $todo = $result->todo_list; for ( @$todo ) { ... } =cut sub todo_list { shift->{todo_list} } 1; Test-Harness-3.36/lib/TAP/Parser/Result/Version.pm0000644000175000017500000000166212640746046020346 0ustar leonleonpackage TAP::Parser::Result::Version; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a version line is encountered. TAP version 13 ok 1 not ok 2 The first version of TAP to include an explicit version number is 13. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_version ) { print $result->version; } This is merely a synonym for C. =cut sub version { shift->{version} } 1; Test-Harness-3.36/lib/TAP/Parser/Scheduler.pm0000644000175000017500000002642712640746046017367 0ustar leonleonpackage TAP::Parser::Scheduler; use strict; use warnings; use Carp; use TAP::Parser::Scheduler::Job; use TAP::Parser::Scheduler::Spinner; =head1 NAME TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS use TAP::Parser::Scheduler; =head1 DESCRIPTION =head1 METHODS =head2 Class Methods =head3 C my $sched = TAP::Parser::Scheduler->new(tests => \@tests); my $sched = TAP::Parser::Scheduler->new( tests => [ ['t/test_name.t','Test Description'], ... ], rules => \%rules, ); Given 'tests' and optional 'rules' as input, returns a new C object. Each member of C<@tests> should be either a a test file name, or a two element arrayref, where the first element is a test file name, and the second element is a test description. By default, we'll use the test name as the description. The optional C attribute provides direction on which tests should be run in parallel and which should be run sequentially. If no rule data structure is provided, a default data structure is used which makes every test eligible to be run in parallel: { par => '**' }, The rules data structure is documented more in the next section. =head2 Rules data structure The "C" data structure is the the heart of the scheduler. It allows you to express simple rules like "run all tests in sequence" or "run all tests in parallel except these five tests.". However, the rules structure also supports glob-style pattern matching and recursive definitions, so you can also express arbitarily complicated patterns. The rule must only have one top level key: either 'par' for "parallel" or 'seq' for "sequence". Values must be either strings with possible glob-style matching, or arrayrefs of strings or hashrefs which follow this pattern recursively. Every element in an arrayref directly below a 'par' key is eligible to be run in parallel, while vavalues directly below a 'seq' key must be run in sequence. =head3 Rules examples Here are some examples: # All tests be run in parallel (the default rule) { par => '**' }, # Run all tests in sequence, except those starting with "p" { par => 't/p*.t' }, # Run all tests in parallel, except those starting with "p" { seq => [ { seq => 't/p*.t' }, { par => '**' }, ], } # Run some startup tests in sequence, then some parallel tests than some # teardown tests in sequence. { seq => [ { seq => 't/startup/*.t' }, { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } { seq => 't/shutdown/*.t' }, ], }, =head3 Rules resolution =over 4 =item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one. =item * "First match wins". The first rule that matches a test will be the one that applies. =item * Any test which does not match a rule will be run in sequence at the end of the run. =item * The existence of a rule does not imply selecting a test. You must still specify the tests to run. =item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C in your Harness object. =back =head3 Glob-style pattern matching for rules We implement our own glob-style pattern matching. Here are the patterns it supports: ** is any number of characters, including /, within a pathname * is zero or more characters within a filename/directory name ? is exactly one character within a filename/directory name {foo,bar,baz} is any of foo, bar or baz. \ is an escape character =cut sub new { my $class = shift; croak "Need a number of key, value pairs" if @_ % 2; my %args = @_; my $tests = delete $args{tests} || croak "Need a 'tests' argument"; my $rules = delete $args{rules} || { par => '**' }; croak "Unknown arg(s): ", join ', ', sort keys %args if keys %args; # Turn any simple names into a name, description pair. TODO: Maybe # construct jobs here? my $self = bless {}, $class; $self->_set_rules( $rules, $tests ); return $self; } # Build the scheduler data structure. # # SCHEDULER-DATA ::= JOB # || ARRAY OF ARRAY OF SCHEDULER-DATA # # The nested arrays are the key to scheduling. The outer array contains # a list of things that may be executed in parallel. Whenever an # eligible job is sought any element of the outer array that is ready to # execute can be selected. The inner arrays represent sequential # execution. They can only proceed when the first job is ready to run. sub _set_rules { my ( $self, $rules, $tests ) = @_; # Convert all incoming tests to job objects. # If no test description is provided use the file name as the description. my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) } map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests; my $schedule = $self->_rule_clause( $rules, \@tests ); # If any tests are left add them as a sequential block at the end of # the run. $schedule = [ [ $schedule, @tests ] ] if @tests; $self->{schedule} = $schedule; } sub _rule_clause { my ( $self, $rule, $tests ) = @_; croak 'Rule clause must be a hash' unless 'HASH' eq ref $rule; my @type = keys %$rule; croak 'Rule clause must have exactly one key' unless @type == 1; my %handlers = ( par => sub { [ map { [$_] } @_ ]; }, seq => sub { [ [@_] ] }, ); my $handler = $handlers{ $type[0] } || croak 'Unknown scheduler type: ', $type[0]; my $val = $rule->{ $type[0] }; return $handler->( map { 'HASH' eq ref $_ ? $self->_rule_clause( $_, $tests ) : $self->_expand( $_, $tests ) } 'ARRAY' eq ref $val ? @$val : $val ); } sub _glob_to_regexp { my ( $self, $glob ) = @_; my $nesting; my $pattern; while (1) { if ( $glob =~ /\G\*\*/gc ) { # ** is any number of characters, including /, within a pathname $pattern .= '.*?'; } elsif ( $glob =~ /\G\*/gc ) { # * is zero or more characters within a filename/directory name $pattern .= '[^/]*'; } elsif ( $glob =~ /\G\?/gc ) { # ? is exactly one character within a filename/directory name $pattern .= '[^/]'; } elsif ( $glob =~ /\G\{/gc ) { # {foo,bar,baz} is any of foo, bar or baz. $pattern .= '(?:'; ++$nesting; } elsif ( $nesting and $glob =~ /\G,/gc ) { # , is only special inside {} $pattern .= '|'; } elsif ( $nesting and $glob =~ /\G\}/gc ) { # } that matches { is special. But unbalanced } are not. $pattern .= ')'; --$nesting; } elsif ( $glob =~ /\G(\\.)/gc ) { # A quoted literal $pattern .= $1; } elsif ( $glob =~ /\G([\},])/gc ) { # Sometimes meta characters $pattern .= '\\' . $1; } else { # Eat everything that is not a meta character. $glob =~ /\G([^{?*\\\},]*)/gc; $pattern .= quotemeta $1; } return $pattern if pos $glob == length $glob; } } sub _expand { my ( $self, $name, $tests ) = @_; my $pattern = $self->_glob_to_regexp($name); $pattern = qr/^ $pattern $/x; my @match = (); for ( my $ti = 0; $ti < @$tests; $ti++ ) { if ( $tests->[$ti]->filename =~ $pattern ) { push @match, splice @$tests, $ti, 1; $ti--; } } return @match; } =head2 Instance Methods =head3 C Get a list of all remaining tests. =cut sub get_all { my $self = shift; my @all = $self->_gather( $self->{schedule} ); $self->{count} = @all; @all; } sub _gather { my ( $self, $rule ) = @_; return unless defined $rule; return $rule unless 'ARRAY' eq ref $rule; return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule; } =head3 C Return the next available job as L object or C if none are available. Returns a L if the scheduler still has pending jobs but none are available to run right now. =cut sub get_job { my $self = shift; $self->{count} ||= $self->get_all; my @jobs = $self->_find_next_job( $self->{schedule} ); if (@jobs) { --$self->{count}; return $jobs[0]; } return TAP::Parser::Scheduler::Spinner->new if $self->{count}; return; } sub _not_empty { my $ar = shift; return 1 unless 'ARRAY' eq ref $ar; for (@$ar) { return 1 if _not_empty($_); } return; } sub _is_empty { !_not_empty(@_) } sub _find_next_job { my ( $self, $rule ) = @_; my @queue = (); my $index = 0; while ( $index < @$rule ) { my $seq = $rule->[$index]; # Prune any exhausted items. shift @$seq while @$seq && _is_empty( $seq->[0] ); if (@$seq) { if ( defined $seq->[0] ) { if ( 'ARRAY' eq ref $seq->[0] ) { push @queue, $seq; } else { my $job = splice @$seq, 0, 1, undef; $job->on_finish( sub { shift @$seq } ); return $job; } } ++$index; } else { # Remove the empty sub-array from the array splice @$rule, $index, 1; } } for my $seq (@queue) { if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) { return @jobs; } } return; } =head3 C Return a human readable representation of the scheduling tree. For example: my @tests = (qw{ t/startup/foo.t t/shutdown/foo.t t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t }); my $sched = TAP::Parser::Scheduler->new( tests => \@tests, rules => { seq => [ { seq => 't/startup/*.t' }, { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] }, { seq => 't/shutdown/*.t' }, ], }, ); Produces: par: seq: par: seq: par: seq: 't/startup/foo.t' par: seq: 't/a/foo.t' seq: 't/b/foo.t' seq: 't/c/foo.t' par: seq: 't/shutdown/foo.t' 't/d/foo.t' =cut sub as_string { my $self = shift; return $self->_as_string( $self->{schedule} ); } sub _as_string { my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 ); my $pad = ' ' x 2; my $indent = $pad x $depth; if ( !defined $rule ) { return "$indent(undef)\n"; } elsif ( 'ARRAY' eq ref $rule ) { return unless @$rule; my $type = ( 'par', 'seq' )[ $depth % 2 ]; return join( '', "$indent$type:\n", map { $self->_as_string( $_, $depth + 1 ) } @$rule ); } else { return "$indent'" . $rule->filename . "'\n"; } } 1; Test-Harness-3.36/lib/TAP/Formatter/0000755000175000017500000000000012640746441015606 5ustar leonleonTest-Harness-3.36/lib/TAP/Formatter/Base.pm0000644000175000017500000002713612640746046017030 0ustar leonleonpackage TAP::Formatter::Base; use strict; use warnings; use base 'TAP::Base'; use POSIX qw(strftime); my $MAX_ERRORS = 5; my %VALIDATION_FOR; BEGIN { %VALIDATION_FOR = ( directives => sub { shift; shift }, verbosity => sub { shift; shift }, normalize => sub { shift; shift }, timer => sub { shift; shift }, failures => sub { shift; shift }, comments => sub { shift; shift }, errors => sub { shift; shift }, color => sub { shift; shift }, jobs => sub { shift; shift }, show_count => sub { shift; shift }, stdout => sub { my ( $self, $ref ) = @_; $self->_croak("option 'stdout' needs a filehandle") unless $self->_is_filehandle($ref); return $ref; }, ); sub _is_filehandle { my ( $self, $ref ) = @_; return 0 if !defined $ref; return 1 if ref $ref eq 'GLOB'; # lexical filehandle return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT return 1 if eval { $ref->can('print') }; return 0; } my @getter_setters = qw( _longest _printed_summary_header _colorizer ); __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR ); } =head1 NAME TAP::Formatter::Base - Base class for harness output delegates =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This provides console orientated output formatting for TAP::Harness. =head1 SYNOPSIS use TAP::Formatter::Console; my $harness = TAP::Formatter::Console->new( \%args ); =cut sub _initialize { my ( $self, $arg_for ) = @_; $arg_for ||= {}; $self->SUPER::_initialize($arg_for); my %arg_for = %$arg_for; # force a shallow copy $self->verbosity(0); for my $name ( keys %VALIDATION_FOR ) { my $property = delete $arg_for{$name}; if ( defined $property ) { my $validate = $VALIDATION_FOR{$name}; $self->$name( $self->$validate($property) ); } } if ( my @props = keys %arg_for ) { $self->_croak( "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); } $self->stdout( \*STDOUT ) unless $self->stdout; if ( $self->color ) { require TAP::Formatter::Color; $self->_colorizer( TAP::Formatter::Color->new ); } return $self; } sub verbose { shift->verbosity >= 1 } sub quiet { shift->verbosity <= -1 } sub really_quiet { shift->verbosity <= -2 } sub silent { shift->verbosity <= -3 } =head1 METHODS =head2 Class Methods =head3 C my %args = ( verbose => 1, ) my $harness = TAP::Formatter::Console->new( \%args ); The constructor returns a new C object. If a L is created with no C a C is automatically created. If any of the following options were given to TAP::Harness->new they well be passed to this constructor which accepts an optional hashref whose allowed keys are: =over 4 =item * C Set the verbosity level. =item * C Printing individual test results to STDOUT. =item * C Append run time for each test to output. Uses L if available. =item * C Show test failures (this is a no-op if C is selected). =item * C Show test comments (this is a no-op if C is selected). =item * C Suppressing some test output (mostly failures while tests are running). =item * C Suppressing everything but the tests summary. =item * C Suppressing all output. =item * C If parse errors are found in the TAP output, a note of this will be made in the summary report. To see all of the parse errors, set this argument to true: errors => 1 =item * C If set to a true value, only test results with directives will be displayed. This overrides other settings such as C, C, or C. =item * C A filehandle for catching standard output. =item * C If defined specifies whether color output is desired. If C is not defined it will default to color output if color support is available on the current platform and output is not being redirected. =item * C The number of concurrent jobs this formatter will handle. =item * C Boolean value. If false, disables the C test count which shows up while tests are running. =back Any keys for which the value is C will be ignored. =cut # new supplied by TAP::Base =head3 C Called by Test::Harness before any test output is generated. This is an advisory and may not be called in the case where tests are being supplied to Test::Harness by an iterator. =cut sub prepare { my ( $self, @tests ) = @_; my $longest = 0; for my $test (@tests) { $longest = length $test if length $test > $longest; } $self->_longest($longest); } sub _format_now { strftime "[%H:%M:%S]", localtime } sub _format_name { my ( $self, $test ) = @_; my $name = $test; my $periods = '.' x ( $self->_longest + 2 - length $test ); $periods = " $periods "; if ( $self->timer ) { my $stamp = $self->_format_now(); return "$stamp $name$periods"; } else { return "$name$periods"; } } =head3 C Called to create a new test session. A test session looks like this: my $session = $formatter->open_test( $test, $parser ); while ( defined( my $result = $parser->next ) ) { $session->result($result); exit 1 if $result->is_bailout; } $session->close_test; =cut sub open_test { die "Unimplemented."; } sub _output_success { my ( $self, $msg ) = @_; $self->_output($msg); } =head3 C $harness->summary( $aggregate ); C prints the summary report after all tests are run. The first argument is an aggregate to summarise. An optional second argument may be set to a true value to indicate that the summary is being output as a result of an interrupted test run. =cut sub summary { my ( $self, $aggregate, $interrupted ) = @_; return if $self->silent; my @t = $aggregate->descriptions; my $tests = \@t; my $runtime = $aggregate->elapsed_timestr; my $total = $aggregate->total; my $passed = $aggregate->passed; if ( $self->timer ) { $self->_output( $self->_format_now(), "\n" ); } $self->_failure_output("Test run interrupted!\n") if $interrupted; # TODO: Check this condition still works when all subtests pass but # the exit status is nonzero if ( $aggregate->all_passed ) { $self->_output_success("All tests successful.\n"); } # ~TODO option where $aggregate->skipped generates reports if ( $total != $passed or $aggregate->has_problems ) { $self->_output("\nTest Summary Report"); $self->_output("\n-------------------\n"); for my $test (@$tests) { $self->_printed_summary_header(0); my ($parser) = $aggregate->parsers($test); $self->_output_summary_failure( 'failed', [ ' Failed test: ', ' Failed tests: ' ], $test, $parser ); $self->_output_summary_failure( 'todo_passed', " TODO passed: ", $test, $parser ); # ~TODO this cannot be the default #$self->_output_summary_failure( 'skipped', " Tests skipped: " ); if ( my $exit = $parser->exit ) { $self->_summary_test_header( $test, $parser ); $self->_failure_output(" Non-zero exit status: $exit\n"); } elsif ( my $wait = $parser->wait ) { $self->_summary_test_header( $test, $parser ); $self->_failure_output(" Non-zero wait status: $wait\n"); } if ( my @errors = $parser->parse_errors ) { my $explain; if ( @errors > $MAX_ERRORS && !$self->errors ) { $explain = "Displayed the first $MAX_ERRORS of " . scalar(@errors) . " TAP syntax errors.\n" . "Re-run prove with the -p option to see them all.\n"; splice @errors, $MAX_ERRORS; } $self->_summary_test_header( $test, $parser ); $self->_failure_output( sprintf " Parse errors: %s\n", shift @errors ); for my $error (@errors) { my $spaces = ' ' x 16; $self->_failure_output("$spaces$error\n"); } $self->_failure_output($explain) if $explain; } } } my $files = @$tests; $self->_output("Files=$files, Tests=$total, $runtime\n"); my $status = $aggregate->get_status; $self->_output("Result: $status\n"); } sub _output_summary_failure { my ( $self, $method, $name, $test, $parser ) = @_; # ugly hack. Must rethink this :( my $output = $method eq 'failed' ? '_failure_output' : '_output'; if ( my @r = $parser->$method() ) { $self->_summary_test_header( $test, $parser ); my ( $singular, $plural ) = 'ARRAY' eq ref $name ? @$name : ( $name, $name ); $self->$output( @r == 1 ? $singular : $plural ); my @results = $self->_balanced_range( 40, @r ); $self->$output( sprintf "%s\n" => shift @results ); my $spaces = ' ' x 16; while (@results) { $self->$output( sprintf "$spaces%s\n" => shift @results ); } } } sub _summary_test_header { my ( $self, $test, $parser ) = @_; return if $self->_printed_summary_header; my $spaces = ' ' x ( $self->_longest - length $test ); $spaces = ' ' unless $spaces; my $output = $self->_get_output_method($parser); my $wait = $parser->wait; defined $wait or $wait = '(none)'; $self->$output( sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n", $wait, $parser->tests_run, scalar $parser->failed ); $self->_printed_summary_header(1); } sub _output { my $self = shift; print { $self->stdout } @_; } sub _failure_output { my $self = shift; $self->_output(@_); } sub _balanced_range { my ( $self, $limit, @range ) = @_; @range = $self->_range(@range); my $line = ""; my @lines; my $curr = 0; while (@range) { if ( $curr < $limit ) { my $range = ( shift @range ) . ", "; $line .= $range; $curr += length $range; } elsif (@range) { $line =~ s/, $//; push @lines => $line; $line = ''; $curr = 0; } } if ($line) { $line =~ s/, $//; push @lines => $line; } return @lines; } sub _range { my ( $self, @numbers ) = @_; # shouldn't be needed, but subclasses might call this @numbers = sort { $a <=> $b } @numbers; my ( $min, @range ); for my $i ( 0 .. $#numbers ) { my $num = $numbers[$i]; my $next = $numbers[ $i + 1 ]; if ( defined $next && $next == $num + 1 ) { if ( !defined $min ) { $min = $num; } } elsif ( defined $min ) { push @range => "$min-$num"; undef $min; } else { push @range => $num; } } return @range; } sub _get_output_method { my ( $self, $parser ) = @_; return $parser->has_problems ? '_failure_output' : '_output'; } 1; Test-Harness-3.36/lib/TAP/Formatter/File/0000755000175000017500000000000012640746441016465 5ustar leonleonTest-Harness-3.36/lib/TAP/Formatter/File/Session.pm0000644000175000017500000000425112640746046020451 0ustar leonleonpackage TAP::Formatter::File::Session; use strict; use warnings; use base 'TAP::Formatter::Session'; =head1 NAME TAP::Formatter::File::Session - Harness output delegate for file output =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This provides file orientated output formatting for L. It is particularly important when running with parallel tests, as it ensures that test results are not interleaved, even when run verbosely. =cut =head1 METHODS =head2 result Stores results for later output, all together. =cut sub result { my $self = shift; my $result = shift; my $parser = $self->parser; my $formatter = $self->formatter; if ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); return; } if (!$formatter->quiet && ( $formatter->verbose || ( $result->is_test && $formatter->failures && !$result->is_ok ) || ( $formatter->comments && $result->is_comment ) || ( $result->has_directive && $formatter->directives ) ) ) { $self->{results} .= $self->_format_for_output($result) . "\n"; } } =head2 close_test When the test file finishes, outputs the summary, together. =cut sub close_test { my $self = shift; # Avoid circular references $self->parser(undef); my $parser = $self->parser; my $formatter = $self->formatter; my $pretty = $formatter->_format_name( $self->name ); return if $formatter->really_quiet; if ( my $skip_all = $parser->skip_all ) { $formatter->_output( $pretty . "skipped: $skip_all\n" ); } elsif ( $parser->has_problems ) { $formatter->_output( $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) ); $self->_output_test_failure($parser); } else { my $time_report = $self->time_report($formatter, $parser); $formatter->_output( $pretty . ( $self->{results} ? "\n" . $self->{results} : "" ) . $self->_make_ok_line($time_report) ); } } 1; Test-Harness-3.36/lib/TAP/Formatter/Console/0000755000175000017500000000000012640746441017210 5ustar leonleonTest-Harness-3.36/lib/TAP/Formatter/Console/ParallelSession.pm0000644000175000017500000001012712640746046022650 0ustar leonleonpackage TAP::Formatter::Console::ParallelSession; use strict; use warnings; use File::Spec; use File::Path; use Carp; use base 'TAP::Formatter::Console::Session'; use constant WIDTH => 72; # Because Eric says my %shared; sub _initialize { my ( $self, $arg_for ) = @_; $self->SUPER::_initialize($arg_for); my $formatter = $self->formatter; # Horrid bodge. This creates our shared context per harness. Maybe # TAP::Harness should give us this? my $context = $shared{$formatter} ||= $self->_create_shared_context; push @{ $context->{active} }, $self; return $self; } sub _create_shared_context { my $self = shift; return { active => [], tests => 0, fails => 0, }; } =head1 NAME TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This provides console orientated output formatting for L when run with multiple L. =head1 SYNOPSIS =cut =head1 METHODS =head2 Class Methods =head3 C
Output test preamble =cut sub header { } sub _clear_ruler { my $self = shift; $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" ); } my $now = 0; my $start; my $trailer = '... )==='; my $chop_length = WIDTH - length $trailer; sub _output_ruler { my ( $self, $refresh ) = @_; my $new_now = time; return if $new_now == $now and !$refresh; $now = $new_now; $start ||= $now; my $formatter = $self->formatter; return if $formatter->really_quiet; my $context = $shared{$formatter}; my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; for my $active ( @{ $context->{active} } ) { my $parser = $active->parser; my $tests = $parser->tests_run; my $planned = $parser->tests_planned || '?'; $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests; } chop $ruler; # Remove a trailing space $ruler .= ')==='; if ( length $ruler > WIDTH ) { $ruler =~ s/(.{$chop_length}).*/$1$trailer/o; } else { $ruler .= '=' x ( WIDTH - length($ruler) ); } $formatter->_output("\r$ruler"); } =head3 C Called by the harness for each line of TAP it receives . =cut sub result { my ( $self, $result ) = @_; my $formatter = $self->formatter; # my $really_quiet = $formatter->really_quiet; # my $show_count = $self->_should_show_count; if ( $result->is_test ) { my $context = $shared{$formatter}; $context->{tests}++; my $active = $context->{active}; if ( @$active == 1 ) { # There is only one test, so use the serial output format. return $self->SUPER::result($result); } $self->_output_ruler( $self->parser->tests_run == 1 ); } elsif ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); } } =head3 C =cut sub clear_for_close { my $self = shift; my $formatter = $self->formatter; return if $formatter->really_quiet; my $context = $shared{$formatter}; if ( @{ $context->{active} } == 1 ) { $self->SUPER::clear_for_close; } else { $self->_clear_ruler; } } =head3 C =cut sub close_test { my $self = shift; my $name = $self->name; my $parser = $self->parser; my $formatter = $self->formatter; my $context = $shared{$formatter}; $self->SUPER::close_test; my $active = $context->{active}; my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active; die "Can't find myself" unless @pos; splice @$active, $pos[0], 1; if ( @$active > 1 ) { $self->_output_ruler(1); } elsif ( @$active == 1 ) { # Print out "test/name.t ...." $active->[0]->SUPER::header; } else { # $self->formatter->_output("\n"); delete $shared{$formatter}; } } 1; Test-Harness-3.36/lib/TAP/Formatter/Console/Session.pm0000644000175000017500000001262712640746046021202 0ustar leonleonpackage TAP::Formatter::Console::Session; use strict; use warnings; use base 'TAP::Formatter::Session'; my @ACCESSOR; BEGIN { my @CLOSURE_BINDING = qw( header result clear_for_close close_test ); for my $method (@CLOSURE_BINDING) { no strict 'refs'; *$method = sub { my $self = shift; return ( $self->{_closures} ||= $self->_closures )->{$method} ->(@_); }; } } =head1 NAME TAP::Formatter::Console::Session - Harness output delegate for default console output =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This provides console orientated output formatting for TAP::Harness. =cut sub _get_output_result { my $self = shift; my @color_map = ( { test => sub { $_->is_test && !$_->is_ok }, colors => ['red'], }, { test => sub { $_->is_test && $_->has_skip }, colors => [ 'white', 'on_blue' ], }, { test => sub { $_->is_test && $_->has_todo }, colors => ['yellow'], }, ); my $formatter = $self->formatter; my $parser = $self->parser; return $formatter->_colorizer ? sub { my $result = shift; for my $col (@color_map) { local $_ = $result; if ( $col->{test}->() ) { $formatter->_set_colors( @{ $col->{colors} } ); last; } } $formatter->_output( $self->_format_for_output($result) ); $formatter->_set_colors('reset'); } : sub { $formatter->_output( $self->_format_for_output(shift) ); }; } sub _closures { my $self = shift; my $parser = $self->parser; my $formatter = $self->formatter; my $pretty = $formatter->_format_name( $self->name ); my $show_count = $self->show_count; my $really_quiet = $formatter->really_quiet; my $quiet = $formatter->quiet; my $verbose = $formatter->verbose; my $directives = $formatter->directives; my $failures = $formatter->failures; my $comments = $formatter->comments; my $output_result = $self->_get_output_result; my $output = '_output'; my $plan = ''; my $newline_printed = 0; my $last_status_printed = 0; return { header => sub { $formatter->_output($pretty) unless $really_quiet; }, result => sub { my $result = shift; if ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); } return if $really_quiet; my $is_test = $result->is_test; # These are used in close_test - but only if $really_quiet # is false - so it's safe to only set them here unless that # relationship changes. if ( !$plan ) { my $planned = $parser->tests_planned || '?'; $plan = "/$planned "; } $output = $formatter->_get_output_method($parser); if ( $show_count and $is_test ) { my $number = $result->number; my $now = CORE::time; # Print status roughly once per second. # We will always get the first number as a side effect of # $last_status_printed starting with the value 0, which $now # will never be. (Unless someone sets their clock to 1970) if ( $last_status_printed != $now ) { $formatter->$output("\r$pretty$number$plan"); $last_status_printed = $now; } } if (!$quiet && ( $verbose || ( $is_test && $failures && !$result->is_ok ) || ( $comments && $result->is_comment ) || ( $directives && $result->has_directive ) ) ) { unless ($newline_printed) { $formatter->_output("\n"); $newline_printed = 1; } $output_result->($result); $formatter->_output("\n"); } }, clear_for_close => sub { my $spaces = ' ' x length( '.' . $pretty . $plan . $parser->tests_run ); $formatter->$output("\r$spaces"); }, close_test => sub { if ( $show_count && !$really_quiet ) { $self->clear_for_close; $formatter->$output("\r$pretty"); } # Avoid circular references $self->parser(undef); $self->{_closures} = {}; return if $really_quiet; if ( my $skip_all = $parser->skip_all ) { $formatter->_output("skipped: $skip_all\n"); } elsif ( $parser->has_problems ) { $self->_output_test_failure($parser); } else { my $time_report = $self->time_report($formatter, $parser); $formatter->_output( $self->_make_ok_line($time_report) ); } }, }; } =head2 C<< clear_for_close >> =head2 C<< close_test >> =head2 C<< header >> =head2 C<< result >> =cut 1; Test-Harness-3.36/lib/TAP/Formatter/Session.pm0000644000175000017500000001157412640746046017600 0ustar leonleonpackage TAP::Formatter::Session; use strict; use warnings; use base 'TAP::Base'; my @ACCESSOR; BEGIN { @ACCESSOR = qw( name formatter parser show_count ); for my $method (@ACCESSOR) { no strict 'refs'; *$method = sub { shift->{$method} }; } } =head1 NAME TAP::Formatter::Session - Abstract base class for harness output delegate =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 METHODS =head2 Class Methods =head3 C my %args = ( formatter => $self, ) my $harness = TAP::Formatter::Console::Session->new( \%args ); The constructor returns a new C object. =over 4 =item * C =item * C =item * C =item * C =back =cut sub _initialize { my ( $self, $arg_for ) = @_; $arg_for ||= {}; $self->SUPER::_initialize($arg_for); my %arg_for = %$arg_for; # force a shallow copy for my $name (@ACCESSOR) { $self->{$name} = delete $arg_for{$name}; } if ( !defined $self->show_count ) { $self->{show_count} = 1; # defaults to true } if ( $self->show_count ) { # but may be a damned lie! $self->{show_count} = $self->_should_show_count; } if ( my @props = sort keys %arg_for ) { $self->_croak( "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); } return $self; } =head3 C
Output test preamble =head3 C Called by the harness for each line of TAP it receives. =head3 C Called to close a test session. =head3 C Called by C to clear the line showing test progress, or the parallel test ruler, prior to printing the final test result. =head3 C Return a formatted string about the elapsed (wall-clock) time and about the consumed CPU time. =cut sub header { } sub result { } sub close_test { } sub clear_for_close { } sub _should_show_count { my $self = shift; return !$self->formatter->verbose && -t $self->formatter->stdout && !$ENV{HARNESS_NOTTY}; } sub _format_for_output { my ( $self, $result ) = @_; return $self->formatter->normalize ? $result->as_string : $result->raw; } sub _output_test_failure { my ( $self, $parser ) = @_; my $formatter = $self->formatter; return if $formatter->really_quiet; my $tests_run = $parser->tests_run; my $tests_planned = $parser->tests_planned; my $total = defined $tests_planned ? $tests_planned : $tests_run; my $passed = $parser->passed; # The total number of fails includes any tests that were planned but # didn't run my $failed = $parser->failed + $total - $tests_run; my $exit = $parser->exit; if ( my $exit = $parser->exit ) { my $wstat = $parser->wait; my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat ); $formatter->_failure_output("Dubious, test returned $status\n"); } if ( $failed == 0 ) { $formatter->_failure_output( $total ? "All $total subtests passed " : 'No subtests run ' ); } else { $formatter->_failure_output("Failed $failed/$total subtests "); if ( !$total ) { $formatter->_failure_output("\nNo tests run!"); } } if ( my $skipped = $parser->skipped ) { $passed -= $skipped; my $test = 'subtest' . ( $skipped != 1 ? 's' : '' ); $formatter->_output( "\n\t(less $skipped skipped $test: $passed okay)"); } if ( my $failed = $parser->todo_passed ) { my $test = $failed > 1 ? 'tests' : 'test'; $formatter->_output( "\n\t($failed TODO $test unexpectedly succeeded)"); } $formatter->_output("\n"); } sub _make_ok_line { my ( $self, $suffix ) = @_; return "ok$suffix\n"; } sub time_report { my ( $self, $formatter, $parser ) = @_; my @time_report; if ( $formatter->timer ) { my $start_time = $parser->start_time; my $end_time = $parser->end_time; if ( defined $start_time and defined $end_time ) { my $elapsed = $end_time - $start_time; push @time_report, $self->time_is_hires ? sprintf( ' %8d ms', $elapsed * 1000 ) : sprintf( ' %8s s', $elapsed || '<1' ); } my $start_times = $parser->start_times(); my $end_times = $parser->end_times(); my $usr = $end_times->[0] - $start_times->[0]; my $sys = $end_times->[1] - $start_times->[1]; my $cusr = $end_times->[2] - $start_times->[2]; my $csys = $end_times->[3] - $start_times->[3]; push @time_report, sprintf('(%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)', $usr, $sys, $cusr, $csys, $usr + $sys + $cusr + $csys); } return "@time_report"; } 1; Test-Harness-3.36/lib/TAP/Formatter/Console.pm0000644000175000017500000000371312640746046017553 0ustar leonleonpackage TAP::Formatter::Console; use strict; use warnings; use base 'TAP::Formatter::Base'; use POSIX qw(strftime); =head1 NAME TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This provides console orientated output formatting for TAP::Harness. =head1 SYNOPSIS use TAP::Formatter::Console; my $harness = TAP::Formatter::Console->new( \%args ); =head2 C<< open_test >> See L =cut sub open_test { my ( $self, $test, $parser ) = @_; my $class = $self->jobs > 1 ? 'TAP::Formatter::Console::ParallelSession' : 'TAP::Formatter::Console::Session'; eval "require $class"; $self->_croak($@) if $@; my $session = $class->new( { name => $test, formatter => $self, parser => $parser, show_count => $self->show_count, } ); $session->header; return $session; } # Use _colorizer delegate to set output color. NOP if we have no delegate sub _set_colors { my ( $self, @colors ) = @_; if ( my $colorizer = $self->_colorizer ) { my $output_func = $self->{_output_func} ||= sub { $self->_output(@_); }; $colorizer->set_color( $output_func, $_ ) for @colors; } } sub _failure_color { my ($self) = @_; return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red'; } sub _success_color { my ($self) = @_; return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green'; } sub _output_success { my ( $self, $msg ) = @_; $self->_set_colors( $self->_success_color() ); $self->_output($msg); $self->_set_colors('reset'); } sub _failure_output { my $self = shift; $self->_set_colors( $self->_failure_color() ); my $out = join '', @_; my $has_newline = chomp $out; $self->_output($out); $self->_set_colors('reset'); $self->_output($/) if $has_newline; } 1; Test-Harness-3.36/lib/TAP/Formatter/File.pm0000644000175000017500000000152212640746046017024 0ustar leonleonpackage TAP::Formatter::File; use strict; use warnings; use TAP::Formatter::File::Session; use POSIX qw(strftime); use base 'TAP::Formatter::Base'; =head1 NAME TAP::Formatter::File - Harness output delegate for file output =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION This provides file orientated output formatting for TAP::Harness. =head1 SYNOPSIS use TAP::Formatter::File; my $harness = TAP::Formatter::File->new( \%args ); =head2 C<< open_test >> See L =cut sub open_test { my ( $self, $test, $parser ) = @_; my $session = TAP::Formatter::File::Session->new( { name => $test, formatter => $self, parser => $parser, } ); $session->header; return $session; } sub _should_show_count { return 0; } 1; Test-Harness-3.36/lib/TAP/Formatter/Color.pm0000644000175000017500000000632112640746046017225 0ustar leonleonpackage TAP::Formatter::Color; use strict; use warnings; use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use base 'TAP::Object'; my $NO_COLOR; BEGIN { $NO_COLOR = 0; if (IS_WIN32) { eval 'use Win32::Console'; if ($@) { $NO_COLOR = $@; } else { my $console = Win32::Console->new( STD_OUTPUT_HANDLE() ); # eval here because we might not know about these variables my $fg = eval '$FG_LIGHTGRAY'; my $bg = eval '$BG_BLACK'; *set_color = sub { my ( $self, $output, $color ) = @_; my $var; if ( $color eq 'reset' ) { $fg = eval '$FG_LIGHTGRAY'; $bg = eval '$BG_BLACK'; } elsif ( $color =~ /^on_(.+)$/ ) { $bg = eval '$BG_' . uc($1); } else { $fg = eval '$FG_' . uc($color); } # In case of colors that aren't defined $self->set_color('reset') unless defined $bg && defined $fg; $console->Attr( $bg | $fg ); }; } } else { eval 'use Term::ANSIColor'; if ($@) { $NO_COLOR = $@; } else { *set_color = sub { my ( $self, $output, $color ) = @_; $output->( color($color) ); }; } } if ($NO_COLOR) { *set_color = sub { }; } } =head1 NAME TAP::Formatter::Color - Run Perl test scripts with color =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 DESCRIPTION Note that this harness is I. You may not like the colors I've chosen and I haven't yet provided an easy way to override them. This test harness is the same as L, but test results are output in color. Passing tests are printed in green. Failing tests are in red. Skipped tests are blue on a white background and TODO tests are printed in white. If L cannot be found (or L if running under Windows) tests will be run without color. =head1 SYNOPSIS use TAP::Formatter::Color; my $harness = TAP::Formatter::Color->new( \%args ); $harness->runtests(@tests); =head1 METHODS =head2 Class Methods =head3 C The constructor returns a new C object. If L is not installed, returns undef. =cut # new() implementation supplied by TAP::Object sub _initialize { my $self = shift; if ($NO_COLOR) { # shorten that message a bit ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s; warn "Note: Cannot run tests in color: $error\n"; return; # abort object construction } return $self; } ############################################################################## =head3 C Test::Formatter::Color->can_color() Returns a boolean indicating whether or not this module can actually generate colored output. This will be false if it could not load the modules needed for the current platform. =cut sub can_color { return !$NO_COLOR; } =head3 C Set the output color. =cut 1; Test-Harness-3.36/lib/TAP/Base.pm0000644000175000017500000000437512640746046015065 0ustar leonleonpackage TAP::Base; use strict; use warnings; use base 'TAP::Object'; =head1 NAME TAP::Base - Base class that provides common functionality to L and L =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; use constant GOT_TIME_HIRES => do { eval 'use Time::HiRes qw(time);'; $@ ? 0 : 1; }; =head1 SYNOPSIS package TAP::Whatever; use base 'TAP::Base'; # ... later ... my $thing = TAP::Whatever->new(); $thing->callback( event => sub { # do something interesting } ); =head1 DESCRIPTION C provides callback management. =head1 METHODS =head2 Class Methods =cut sub _initialize { my ( $self, $arg_for, $ok_callback ) = @_; my %ok_map = map { $_ => 1 } @$ok_callback; $self->{ok_callbacks} = \%ok_map; if ( my $cb = delete $arg_for->{callbacks} ) { while ( my ( $event, $callback ) = each %$cb ) { $self->callback( $event, $callback ); } } return $self; } =head3 C Install a callback for a named event. =cut sub callback { my ( $self, $event, $callback ) = @_; my %ok_map = %{ $self->{ok_callbacks} }; $self->_croak('No callbacks may be installed') unless %ok_map; $self->_croak( "Callback $event is not supported. Valid callbacks are " . join( ', ', sort keys %ok_map ) ) unless exists $ok_map{$event}; push @{ $self->{code_for}{$event} }, $callback; return; } sub _has_callbacks { my $self = shift; return keys %{ $self->{code_for} } != 0; } sub _callback_for { my ( $self, $event ) = @_; return $self->{code_for}{$event}; } sub _make_callback { my $self = shift; my $event = shift; my $cb = $self->_callback_for($event); return unless defined $cb; return map { $_->(@_) } @$cb; } =head3 C Return the current time using Time::HiRes if available. =cut sub get_time { return time() } =head3 C Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available). =cut sub time_is_hires { return GOT_TIME_HIRES } =head3 C Return array reference of the four-element list of CPU seconds, as with L. =cut sub get_times { return [ times() ] } 1; Test-Harness-3.36/lib/TAP/Object.pm0000644000175000017500000000521012640746046015406 0ustar leonleonpackage TAP::Object; use strict; use warnings; =head1 NAME TAP::Object - Base class that provides common functionality to all C modules =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; =head1 SYNOPSIS package TAP::Whatever; use strict; use base 'TAP::Object'; # new() implementation by TAP::Object sub _initialize { my ( $self, @args) = @_; # initialize your object return $self; } # ... later ... my $obj = TAP::Whatever->new(@args); =head1 DESCRIPTION C provides a default constructor and exception model for all C classes. Exceptions are raised using L. =head1 METHODS =head2 Class Methods =head3 C Create a new object. Any arguments passed to C will be passed on to the L method. Returns a new object. =cut sub new { my $class = shift; my $self = bless {}, $class; return $self->_initialize(@_); } =head2 Instance Methods =head3 C<_initialize> Initializes a new object. This method is a stub by default, you should override it as appropriate. I L expects you to return C<$self> or raise an exception. See L, and L. =cut sub _initialize { return $_[0]; } =head3 C<_croak> Raise an exception using C from L, eg: $self->_croak( 'why me?', 'aaarrgh!' ); May also be called as a I method. $class->_croak( 'this works too' ); =cut sub _croak { my $proto = shift; require Carp; Carp::croak(@_); return; } =head3 C<_confess> Raise an exception using C from L, eg: $self->_confess( 'why me?', 'aaarrgh!' ); May also be called as a I 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. =cut sub _construct { my ( $self, $class, @args ) = @_; $self->_croak("Bad module name $class") unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; unless ( $class->can('new') ) { local $@; eval "require $class"; $self->_croak("Can't load $class: $@") if $@; } return $class->new(@args); } =head3 C Create simple getter/setters. __PACKAGE__->mk_methods(@method_names); =cut sub mk_methods { my ( $class, @methods ) = @_; for my $method_name (@methods) { my $method = "${class}::$method_name"; no strict 'refs'; *$method = sub { my $self = shift; $self->{$method_name} = shift if @_; return $self->{$method_name}; }; } } 1; Test-Harness-3.36/lib/TAP/Harness/0000755000175000017500000000000012640746441015246 5ustar leonleonTest-Harness-3.36/lib/TAP/Harness/Beyond.pod0000644000175000017500000003633512514133675017203 0ustar leonleon=head1 NAME Test::Harness::Beyond - Beyond make test =head1 Beyond make test Test::Harness is responsible for running test scripts, analysing their output and reporting success or failure. When I type F (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 to the F 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 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; like F 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 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, typing F 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 instead prove -Ilib -r t So far I've shown you nothing that F 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 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 into and I from the parser. L supports arbitrary plugins, and L supports custom I and I that you can load using either L or L; there are many examples to base mine on. For more details see L, L, and L. 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 '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. =for comment The URLs in [1] and [2] point to 404 pages. What are currently the correct URLs? [1] L [2] L [3] L Test-Harness-3.36/lib/TAP/Harness/Env.pm0000644000175000017500000001245012640746046016337 0ustar leonleonpackage TAP::Harness::Env; use strict; use warnings; use constant IS_VMS => ( $^O eq 'VMS' ); use TAP::Object; use Text::ParseWords qw/shellwords/; our $VERSION = '3.36'; # Get the parts of @INC which are changed from the stock list AND # preserve reordering of stock directories. sub _filtered_inc_vms { my @inc = grep { !ref } @INC; #28567 # VMS has a 255-byte limit on the length of %ENV entries, so # toss the ones that involve perl_root, the install location @inc = grep { !/perl_root/i } @inc; my @default_inc = _default_inc(); my @new_inc; my %seen; for my $dir (@inc) { next if $seen{$dir}++; if ( $dir eq ( $default_inc[0] || '' ) ) { shift @default_inc; } else { push @new_inc, $dir; } shift @default_inc while @default_inc and $seen{ $default_inc[0] }; } return @new_inc; } # Cache this to avoid repeatedly shelling out to Perl. my @inc; sub _default_inc { return @inc if @inc; local $ENV{PERL5LIB}; local $ENV{PERLLIB}; 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[]"` ); return @inc; } sub create { my $package = shift; my %input = %{ shift || {} }; my @libs = @{ delete $input{libs} || [] }; my @raw_switches = @{ delete $input{switches} || [] }; my @opt = ( @raw_switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} || '' ) ); my @switches; while ( my $opt = shift @opt ) { if ( $opt =~ /^ -I (.*) $ /x ) { push @libs, length($1) ? $1 : shift @opt; } else { push @switches, $opt; } } # Do things the old way on VMS... push @libs, _filtered_inc_vms() if IS_VMS; # If $Verbose isn't numeric default to 1. This helps core. my $verbose = $ENV{HARNESS_VERBOSE} ? $ENV{HARNESS_VERBOSE} !~ /\d/ ? 1 : $ENV{HARNESS_VERBOSE} : 0; my %args = ( lib => \@libs, timer => $ENV{HARNESS_TIMER} || 0, switches => \@switches, color => $ENV{HARNESS_COLOR} || 0, verbosity => $verbose, ignore_exit => $ENV{HARNESS_IGNORE_EXIT} || 0, ); my $class = delete $input{harness_class} || $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { for my $opt ( split /:/, $env_opt ) { if ( $opt =~ /^j(\d*)$/ ) { $args{jobs} = $1 || 9; } elsif ( $opt eq 'c' ) { $args{color} = 1; } elsif ( $opt =~ m/^f(.*)$/ ) { my $fmt = $1; $fmt =~ s/-/::/g; $args{formatter_class} = $fmt; } elsif ( $opt =~ m/^a(.*)$/ ) { my $archive = $1; $class = 'TAP::Harness::Archive'; $args{archive} = $archive; } else { die "Unknown HARNESS_OPTIONS item: $opt\n"; } } } return TAP::Object->_construct($class, { %args, %input }); } 1; =head1 NAME TAP::Harness::Env - Parsing harness related environmental variables where appropriate =head1 VERSION Version 3.36 =head1 SYNOPSIS my $harness = TAP::Harness::Env->create(\%extra_args) =head1 DESCRIPTION This module implements the environmental variables that L uses with TAP::Harness, and instantiates the appropriate class with the appropriate arguments. =head1 METHODS =over 4 =item * create( \%args ) This function reads the environment and generates an appropriate argument hash from it. If given any arguments in C<%extra_args>, these will override the environmental defaults. In accepts C (which defaults to C), and any argument the harness class accepts. =back =head1 ENVIRONMENTAL VARIABLES =over 4 =item C Setting this adds perl command line switches to each test file run. For example, C will turn on taint mode. C will run C for each test. =item C If true, C will output the verbose results of running its tests. =item C Specifies a TAP::Harness subclass to be used in place of TAP::Harness. =item C Provide additional options to the harness. Currently supported options are: =over =item C<< j >> Run (default 9) parallel jobs. =item C<< c >> Try to color output. See L. =item C<< a >> Will use L as the harness class, and save the TAP to C =item C<< fPackage-With-Dashes >> Set the formatter_class of the harness being run. Since the C is seperated by C<:>, we use C<-> instead. =back Multiple options may be separated by colons: HARNESS_OPTIONS=j9:c make test =item C Setting this to true will make the harness display the number of milliseconds each test took. You can also use F's C<--timer> switch. =item C Attempt to produce color output. =item C If set to a true value instruct C to ignore exit and wait status from test scripts. =back Test-Harness-3.36/lib/TAP/Harness.pm0000644000175000017500000007051612640746046015616 0ustar leonleonpackage TAP::Harness; use strict; use warnings; use Carp; use File::Spec; use File::Path; use IO::Handle; use base 'TAP::Base'; =head1 NAME TAP::Harness - Run test scripts with statistics =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; END { # For VMS. delete $ENV{HARNESS_ACTIVE}; delete $ENV{HARNESS_VERSION}; } =head1 DESCRIPTION This is a simple test harness which allows tests to be run and results automatically aggregated and output to STDOUT. =head1 SYNOPSIS use TAP::Harness; my $harness = TAP::Harness->new( \%args ); $harness->runtests(@tests); =cut my %VALIDATION_FOR; my @FORMATTER_ARGS; sub _error { my $self = shift; return $self->{error} unless @_; $self->{error} = shift; } BEGIN { @FORMATTER_ARGS = qw( directives verbosity timer failures comments errors stdout color show_count normalize ); %VALIDATION_FOR = ( lib => sub { my ( $self, $libs ) = @_; $libs = [$libs] unless 'ARRAY' eq ref $libs; return [ map {"-I$_"} @$libs ]; }, switches => sub { shift; shift }, exec => sub { shift; shift }, merge => sub { shift; shift }, aggregator_class => sub { shift; shift }, formatter_class => sub { shift; shift }, multiplexer_class => sub { shift; shift }, parser_class => sub { shift; shift }, scheduler_class => sub { shift; shift }, formatter => sub { shift; shift }, jobs => sub { shift; shift }, test_args => sub { shift; shift }, ignore_exit => sub { shift; shift }, rules => sub { shift; shift }, rulesfile => sub { shift; shift }, sources => sub { shift; shift }, version => sub { shift; shift }, trap => sub { shift; shift }, ); for my $method ( sort keys %VALIDATION_FOR ) { no strict 'refs'; if ( $method eq 'lib' || $method eq 'switches' ) { *{$method} = sub { my $self = shift; unless (@_) { $self->{$method} ||= []; return wantarray ? @{ $self->{$method} } : $self->{$method}; } $self->_croak("Too many arguments to method '$method'") if @_ > 1; my $args = shift; $args = [$args] unless ref $args; $self->{$method} = $args; return $self; }; } else { *{$method} = sub { my $self = shift; return $self->{$method} unless @_; $self->{$method} = shift; }; } } for my $method (@FORMATTER_ARGS) { no strict 'refs'; *{$method} = sub { my $self = shift; return $self->formatter->$method(@_); }; } } ############################################################################## =head1 METHODS =head2 Class Methods =head3 C my %args = ( verbosity => 1, lib => [ 'lib', 'blib/lib', 'blib/arch' ], ) my $harness = TAP::Harness->new( \%args ); The constructor returns a new C object. It accepts an optional hashref whose allowed keys are: =over 4 =item * C Set the verbosity level: 1 verbose Print individual test results to STDOUT. 0 normal -1 quiet Suppress some test output (mostly failures while tests are running). -2 really quiet Suppress everything but the tests summary. -3 silent Suppress everything. =item * C Append run time for each test to output. Uses L if available. =item * C Show test failures (this is a no-op if C is selected). =item * C Show test comments (this is a no-op if C is selected). =item * C Update the running test count during testing. =item * C Set to a true value to normalize the TAP that is emitted in verbose modes. =item * C Accepts a scalar value or array ref of scalar values indicating which paths to allowed libraries should be included if Perl tests are executed. Naturally, this only makes sense in the context of tests written in Perl. =item * C Accepts a scalar value or array ref of scalar values indicating which switches should be included if Perl tests are executed. Naturally, this only makes sense in the context of tests written in Perl. =item * C 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 Attempt to produce color output. =item * C Typically, Perl tests are run through this. However, anything which spits out TAP is fine. You can use this argument to specify the name of the program (and optional switches) to run your tests with: exec => ['/usr/bin/ruby', '-w'] You can also pass a subroutine reference in order to determine and return the proper program to run based on a given test script. The subroutine reference should expect the TAP::Harness object itself as the first argument, and the file name as the second argument. It should return an array reference containing the command to be run and including the test file name. It can also simply return C, in which case TAP::Harness will fall back on executing the test script in Perl: exec => sub { my ( $harness, $test_file ) = @_; # Let Perl tests run. return undef if $test_file =~ /[.]t$/; return [ qw( /usr/bin/ruby -w ), $test_file ] if $test_file =~ /[.]rb$/; } If the subroutine returns a scalar with a newline or a filehandle, it will be interpreted as raw TAP or as a TAP stream, respectively. =item * C If C is true the harness will create parsers that merge STDOUT and STDERR together for any processes they start. =item * C I. If set, C must be a hashref containing the names of the Ls to load and/or configure. The values are a hash of configuration that will be accessible to the source handlers via L. For example: sources => { Perl => { exec => '/path/to/custom/perl' }, File => { extensions => [ '.tap', '.txt' ] }, MyCustom => { some => 'config' }, } The C parameter affects how C, C and C parameters are handled. For more details, see the C parameter in L, L, and L. =item * C The name of the class to use to aggregate test results. The default is L. =item * C I. Assume this TAP version for L instead of default TAP version 12. =item * C The name of the class to use to format output. The default is L, or L if the output isn't a TTY. =item * C The name of the class to use to multiplex tests during parallel testing. The default is L. =item * C The name of the class to use to parse TAP. The default is L. =item * C The name of the class to use to schedule test execution. The default is L. =item * C If set C must be an object that is capable of formatting the TAP output. See L for an example. =item * C If parse errors are found in the TAP output, a note of this will be made in the summary report. To see all of the parse errors, set this argument to true: errors => 1 =item * C If set to a true value, only test results with directives will be displayed. This overrides other settings such as C or C. =item * C If set to a true value instruct C to ignore exit and wait status from test scripts. =item * C The maximum number of parallel tests to run at any time. Which tests can be run in parallel is controlled by C. The default is to run only one test at a time. =item * C A reference to a hash of rules that control which tests may be executed in parallel. If no rules are declared and L is available, C attempts to load rules from a YAML file specified by the C parameter. If no rules file exists, the default is for all tests to be eligible to be run in parallel. Here some simple examples. For the full details of the data structure and the related glob-style pattern matching, see L. # Run all tests in sequence, except those starting with "p" $harness->rules({ par => 't/p*.t' }); # Equivalent YAML file --- par: t/p*.t # Run all tests in parallel, except those starting with "p" $harness->rules({ seq => [ { seq => 't/p*.t' }, { par => '**' }, ], }); # Equivalent YAML file --- seq: - seq: t/p*.t - par: ** # Run some startup tests in sequence, then some parallel tests than some # teardown tests in sequence. $harness->rules({ seq => [ { seq => 't/startup/*.t' }, { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } { seq => 't/shutdown/*.t' }, ], }); # Equivalent YAML file --- seq: - seq: t/startup/*.t - par: - t/a/*.t - t/b/*.t - t/c/*.t - seq: t/shutdown/*.t This is an experimental feature and the interface may change. =item * C This specifies where to find a YAML file of test scheduling rules. If not provided, it looks for a default file to use. It first checks for a file given in the C environment variable, then it checks for F and then F. =item * C A filehandle for catching standard output. =item * C Attempt to print summary information if run is interrupted by SIGINT (Ctrl-C). =back Any keys for which the value is C will be ignored. =cut # new supplied by TAP::Base { my @legal_callback = qw( parser_args made_parser before_runtests after_runtests after_test ); my %default_class = ( aggregator_class => 'TAP::Parser::Aggregator', formatter_class => 'TAP::Formatter::Console', multiplexer_class => 'TAP::Parser::Multiplexer', parser_class => 'TAP::Parser', scheduler_class => 'TAP::Parser::Scheduler', ); sub _initialize { my ( $self, $arg_for ) = @_; $arg_for ||= {}; $self->SUPER::_initialize( $arg_for, \@legal_callback ); my %arg_for = %$arg_for; # force a shallow copy for my $name ( sort keys %VALIDATION_FOR ) { my $property = delete $arg_for{$name}; if ( defined $property ) { my $validate = $VALIDATION_FOR{$name}; my $value = $self->$validate($property); if ( $self->_error ) { $self->_croak; } $self->$name($value); } } $self->jobs(1) unless defined $self->jobs; if ( ! defined $self->rules ) { $self->_maybe_load_rulesfile; } local $default_class{formatter_class} = 'TAP::Formatter::File' unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY}; while ( my ( $attr, $class ) = each %default_class ) { $self->$attr( $self->$attr() || $class ); } unless ( $self->formatter ) { # This is a little bodge to preserve legacy behaviour. It's # pretty horrible that we know which args are destined for # the formatter. my %formatter_args = ( jobs => $self->jobs ); for my $name (@FORMATTER_ARGS) { if ( defined( my $property = delete $arg_for{$name} ) ) { $formatter_args{$name} = $property; } } $self->formatter( $self->_construct( $self->formatter_class, \%formatter_args ) ); } if ( my @props = sort keys %arg_for ) { $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); } return $self; } sub _maybe_load_rulesfile { my ($self) = @_; my ($rulesfile) = defined $self->rulesfile ? $self->rulesfile : defined($ENV{HARNESS_RULESFILE}) ? $ENV{HARNESS_RULESFILE} : grep { -r } qw(./testrules.yml t/testrules.yml); if ( defined $rulesfile && -r $rulesfile ) { if ( ! eval { require CPAN::Meta::YAML; 1} ) { warn "CPAN::Meta::YAML required to process $rulesfile" ; return; } my $layer = $] lt "5.008" ? "" : ":encoding(UTF-8)"; open my $fh, "<$layer", $rulesfile or die "Couldn't open $rulesfile: $!"; my $yaml_text = do { local $/; <$fh> }; my $yaml = CPAN::Meta::YAML->read_string($yaml_text) or die CPAN::Meta::YAML->errstr; $self->rules( $yaml->[0] ); } return; } } ############################################################################## =head2 Instance Methods =head3 C $harness->runtests(@tests); 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 as a C. See L for more information. It is possible to provide aliases that will be displayed in place of the test name by supplying the test as a reference to an array containing C<< [ $test, $alias ] >>: $harness->runtests( [ 't/foo.t', 'Foo Once' ], [ 't/foo.t', 'Foo Twice' ] ); Normally it is an error to attempt to run the same test twice. Aliases allow you to overcome this limitation by giving each run of the test a unique name. Tests will be run in the order found. If the environment variable C is defined it should name a directory into which a copy of the raw TAP for each test will be written. TAP is written to files named for each test. Subdirectories will be created as needed. Returns a L containing the test results. =cut sub runtests { my ( $self, @tests ) = @_; my $aggregate = $self->_construct( $self->aggregator_class ); $self->_make_callback( 'before_runtests', $aggregate ); $aggregate->start; my $finish = sub { my $interrupted = shift; $aggregate->stop; $self->summary( $aggregate, $interrupted ); $self->_make_callback( 'after_runtests', $aggregate ); }; my $run = sub { $self->aggregate_tests( $aggregate, @tests ); $finish->(); }; if ( $self->trap ) { local $SIG{INT} = sub { print "\n"; $finish->(1); exit; }; $run->(); } else { $run->(); } return $aggregate; } =head3 C $harness->summary( $aggregator ); Output the summary for a L. =cut sub summary { my ( $self, @args ) = @_; $self->formatter->summary(@args); } sub _after_test { my ( $self, $aggregate, $job, $parser ) = @_; $self->_make_callback( 'after_test', $job->as_array_ref, $parser ); $aggregate->add( $job->description, $parser ); } sub _bailout { my ( $self, $result ) = @_; my $explanation = $result->explanation; die "FAILED--Further testing stopped" . ( $explanation ? ": $explanation\n" : ".\n" ); } sub _aggregate_parallel { my ( $self, $aggregate, $scheduler ) = @_; my $jobs = $self->jobs; my $mux = $self->_construct( $self->multiplexer_class ); RESULT: { # Keep multiplexer topped up FILL: while ( $mux->parsers < $jobs ) { my $job = $scheduler->get_job; # If we hit a spinner stop filling and start running. last FILL if !defined $job || $job->is_spinner; my ( $parser, $session ) = $self->make_parser($job); $mux->add( $parser, [ $session, $job ] ); } if ( my ( $parser, $stash, $result ) = $mux->next ) { my ( $session, $job ) = @$stash; if ( defined $result ) { $session->result($result); $self->_bailout($result) if $result->is_bailout; } else { # End of parser. Automatically removed from the mux. $self->finish_parser( $parser, $session ); $self->_after_test( $aggregate, $job, $parser ); $job->finish; } redo RESULT; } } return; } sub _aggregate_single { my ( $self, $aggregate, $scheduler ) = @_; JOB: while ( my $job = $scheduler->get_job ) { next JOB if $job->is_spinner; my ( $parser, $session ) = $self->make_parser($job); while ( defined( my $result = $parser->next ) ) { $session->result($result); if ( $result->is_bailout ) { # Keep reading until input is exhausted in the hope # of allowing any pending diagnostics to show up. 1 while $parser->next; $self->_bailout($result); } } $self->finish_parser( $parser, $session ); $self->_after_test( $aggregate, $job, $parser ); $job->finish; } return; } =head3 C $harness->aggregate_tests( $aggregate, @tests ); Run the named tests and display a summary of result. Tests will be run in the order found. Test results will be added to the supplied L. C may be called multiple times to run several sets of tests. Multiple C instances may be used to pass results to a single aggregator so that different parts of a complex test suite may be run using different C settings. This is useful, for example, in the case where some tests should run in parallel but others are unsuitable for parallel execution. my $formatter = TAP::Formatter::Console->new; my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); my $par_harness = TAP::Harness->new( { formatter => $formatter, jobs => 9 } ); my $aggregator = TAP::Parser::Aggregator->new; $aggregator->start(); $ser_harness->aggregate_tests( $aggregator, @ser_tests ); $par_harness->aggregate_tests( $aggregator, @par_tests ); $aggregator->stop(); $formatter->summary($aggregator); Note that for simpler testing requirements it will often be possible to replace the above code with a single call to C. Each element of the C<@tests> array is either: =over =item * the source name of a test to run =item * a reference to a [ source name, display name ] array =back In the case of a perl test suite, typically I 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 test more than once when each invocation uses a different name. =cut sub aggregate_tests { my ( $self, $aggregate, @tests ) = @_; my $jobs = $self->jobs; my $scheduler = $self->make_scheduler(@tests); # #12458 local $ENV{HARNESS_IS_VERBOSE} = 1 if $self->formatter->verbosity > 0; # Formatter gets only names. $self->formatter->prepare( map { $_->description } $scheduler->get_all ); if ( $self->jobs > 1 ) { $self->_aggregate_parallel( $aggregate, $scheduler ); } else { $self->_aggregate_single( $aggregate, $scheduler ); } return; } sub _add_descriptions { my $self = shift; # Turn unwrapped scalars into anonymous arrays and copy the name as # the description for tests that have only a name. return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ } map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_; } =head3 C Called by the harness when it needs to create a L. Override in a subclass to provide an alternative scheduler. C is passed the list of tests that was passed to C. =cut sub make_scheduler { my ( $self, @tests ) = @_; return $self->_construct( $self->scheduler_class, tests => [ $self->_add_descriptions(@tests) ], rules => $self->rules ); } =head3 C Gets or sets the number of concurrent test runs the harness is handling. By default, this value is 1 -- for parallel testing, this should be set higher. =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; $args{switches} = \@switches; $args{spool} = $self->_open_spool($test_prog); $args{merge} = $self->merge; $args{ignore_exit} = $self->ignore_exit; $args{version} = $self->version if $self->version; if ( my $exec = $self->exec ) { $args{exec} = ref $exec eq 'CODE' ? $exec->( $self, $test_prog ) : [ @$exec, $test_prog ]; if ( not defined $args{exec} ) { $args{source} = $test_prog; } elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) { $args{source} = delete $args{exec}; } } else { $args{source} = $test_prog; } 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; } return \%args; } =head3 C Make a new parser and display formatter session. Typically used and/or overridden in subclasses. my ( $parser, $session ) = $harness->make_parser; =cut sub make_parser { my ( $self, $job ) = @_; my $args = $self->_get_parser_args($job); $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); my $parser = $self->_construct( $self->parser_class, $args ); $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); my $session = $self->formatter->open_test( $job->description, $parser ); return ( $parser, $session ); } =head3 C Terminate use of a parser. Typically used and/or overridden in subclasses. The parser isn't destroyed as a result of this. =cut sub finish_parser { my ( $self, $parser, $session ) = @_; $session->close_test; $self->_close_spool($parser); return $parser; } sub _open_spool { my $self = shift; my $test = shift; if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { my $spool = File::Spec->catfile( $spool_dir, $test ); # Make the directory my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); my $path = File::Spec->catpath( $vol, $dir, '' ); eval { mkpath($path) }; $self->_croak($@) if $@; my $spool_handle = IO::Handle->new; open( $spool_handle, ">$spool" ) or $self->_croak(" Can't write $spool ( $! ) "); return $spool_handle; } return; } sub _close_spool { my $self = shift; my ($parser) = @_; if ( my $spool_handle = $parser->delete_spool ) { close($spool_handle) or $self->_croak(" Error closing TAP spool file( $! ) \n "); } return; } sub _croak { my ( $self, $message ) = @_; unless ($message) { $message = $self->_error; } $self->SUPER::_croak($message); return; } 1; __END__ ############################################################################## =head1 CONFIGURING C is designed to be easy to configure. =head2 Plugins C plugins let you change the way TAP is I to and I from the parser. Ls handle TAP I. You can configure them and load custom handlers using the C parameter to L. Ls handle TAP I. You can load custom formatters by using the C parameter to L. To configure a formatter, you currently need to instantiate it outside of L and pass it in with the C parameter to L. This I be addressed by adding a I parameter to L in the future. =head2 C L version C<0.30> supports C. To load C plugins, you'll need to use the C parameter to C, typically from your C. 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_class => 'TAP::Formatter::HTML', }, build_requires => { 'Module::Build' => '0.30', 'TAP::Harness' => '3.18', }, )->create_build_script; See L =head2 C L does not support L out-of-the-box. =head2 C L supports C plugins, and has a plugin system of its own. See L, L and L for more details. =head1 WRITING PLUGINS If you can't configure C to do what you want, and you can't find an existing plugin, consider writing one. The two primary use cases supported by L for plugins are I and I: =over 2 =item Customize how TAP gets into the parser To do this, you can either extend an existing L, or write your own. It's a pretty simple API, and they can be loaded and configured using the C parameter to L. =item Customize how TAP results are output from the parser To do this, you can either extend an existing L, or write your own. Writing formatters are a bit more involved than writing a I, as you'll need to understand the L API. A good place to start is by understanding how L works. Custom formatters can be loaded configured using the C parameter to L. =back =head1 SUBCLASSING If you can't configure C 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. =over 4 =item L =item L =item L =back =cut =head1 REPLACING If you like the C utility and L but you want your own harness, all you need to do is write one and provide C and C methods. Then you can use the C utility like so: prove --harness My::Test::Harness Note that while C accepts a list of tests (or things to be tested), C has a fairly rich set of arguments. You'll probably want to read over this code carefully to see how all of them are being used. =head1 SEE ALSO L =cut # vim:ts=4:sw=4:et:sta Test-Harness-3.36/lib/TAP/Parser.pm0000644000175000017500000014566112640746046015453 0ustar leonleonpackage TAP::Parser; use strict; use warnings; 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 ); use base 'TAP::Base'; =encoding utf8 =head1 NAME TAP::Parser - Parse L output =head1 VERSION Version 3.36 =cut our $VERSION = '3.36'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 13; $ENV{TAP_VERSION} = $MAX_TAP_VERSION; END { # For VMS. delete $ENV{TAP_VERSION}; } BEGIN { # making accessors __PACKAGE__->mk_methods( qw( _iterator _spool exec exit is_good_plan plan tests_planned tests_run wait version in_todo start_time end_time start_times end_times skip_all grammar_class result_factory_class iterator_factory_class ) ); sub _stream { # deprecated my $self = shift; $self->_iterator(@_); } } # done making accessors =head1 SYNOPSIS use TAP::Parser; my $parser = TAP::Parser->new( { source => $source } ); while ( my $result = $parser->next ) { print $result->as_string; } =head1 DESCRIPTION C is designed to produce a proper parse of TAP output. For an example of how to run tests through this module, see the simple harnesses C. There's a wiki dedicated to the Test Anything Protocol: L It includes the TAP::Parser Cookbook: L =head1 METHODS =head2 Class Methods =head3 C my $parser = TAP::Parser->new(\%args); Returns a new C object. The arguments should be a hashref with I of the following keys: =over 4 =item * C I This is the preferred method of passing input to the constructor. The C is used to create a L that is passed to the L which in turn figures out how to handle the source and creates a for it. The iterator is used by the parser to read in the TAP stream. To configure the I use the C parameter below. Note that C, C and C are I. =item * C I The value should be the complete TAP output. The I is used to create a L that is passed to the L which in turn figures out how to handle the source and creates a for it. The iterator is used by the parser to read in the TAP stream. To configure the I use the C parameter below. Note that C, C and C are I. =item * C Must be passed an array reference. The I array ref is used to create a L that is passed to the L which in turn figures out how to handle the source and creates a for it. The iterator is used by the parser to read in the TAP stream. By default the L class will create a L object to handle the source. This passes the array reference strings as command arguments to L: exec => [ '/usr/bin/ruby', 't/my_test.rb' ] If any C are given they will be appended to the end of the command argument list. To configure the I use the C parameter below. Note that C, C and C are I. =back The following keys are optional. =over 4 =item * C I. If set, C must be a hashref containing the names of the Ls to load and/or configure. The values are a hash of configuration that will be accessible to the source handlers via L. For example: sources => { Perl => { exec => '/path/to/custom/perl' }, File => { extensions => [ '.tap', '.txt' ] }, MyCustom => { some => 'config' }, } This will cause C to pass custom configuration to two of the built- in source handlers - L, L - and attempt to load the C class. See L for more detail. The C parameter affects how C, C and C parameters are handled. See L, L and subclasses for more details. =item * C If present, each callback corresponding to a given result type will be called with the result as the argument if the C method is used: my %callbacks = ( test => \&test_callback, plan => \&plan_callback, comment => \&comment_callback, bailout => \&bailout_callback, unknown => \&unknown_callback, ); my $aggregator = TAP::Parser::Aggregator->new; for my $file ( @test_files ) { my $parser = TAP::Parser->new( { source => $file, callbacks => \%callbacks, } ); $parser->run; $aggregator->add( $file, $parser ); } =item * C If using a Perl file as a source, optional switches may be passed which will be used when invoking the perl executable. my $parser = TAP::Parser->new( { source => $test_file, switches => [ '-Ilib' ], } ); =item * C Used in conjunction with the C and C option to supply a reference to an C<@ARGV> style array of arguments to pass to the test program. =item * C If passed a filehandle will write a copy of all parsed TAP to that handle. =item * C If false, STDERR is not captured (though it is 'relayed' to keep it somewhat synchronized with STDOUT.) If true, STDERR and STDOUT are the same filehandle. This may cause breakage if STDERR contains anything resembling TAP format, but does allow exact synchronization. Subtleties of this behavior may be platform-dependent and may change in the future. =item * C This option was introduced to let you easily customize which I class the parser should use. It defaults to L. See also L. =item * C This option was introduced to let you easily customize which I factory class the parser should use. It defaults to L. See also L. =item * C I This option was introduced to let you easily customize which I factory class the parser should use. It defaults to L. =back =cut # new() implementation supplied by TAP::Base # This should make overriding behaviour of the Parser in subclasses easier: sub _default_grammar_class {'TAP::Parser::Grammar'} sub _default_result_factory_class {'TAP::Parser::ResultFactory'} sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'} ############################################################################## =head2 Instance Methods =head3 C my $parser = TAP::Parser->new( { source => $file } ); while ( my $result = $parser->next ) { print $result->as_string, "\n"; } This method returns the results of the parsing, one result at a time. Note that it is destructive. You can't rewind and examine previous results. If callbacks are used, they will be issued before this call returns. Each result returned is a subclass of L. See that module and related classes for more information on how to use them. =cut sub next { my $self = shift; return ( $self->{_iter} ||= $self->_iter )->(); } ############################################################################## =head3 C $parser->run; This method merely runs the parser and parses all of the TAP. =cut sub run { my $self = shift; while ( defined( my $result = $self->next ) ) { # do nothing } } ############################################################################## =head3 C Make a new L object and return it. Passes through any arguments given. The C can be customized, as described in L. =head3 C Make a new L object using the parser's L, and return it. Passes through any arguments given. The C can be customized, as described in L. =head3 C I. Make a new L object and return it. Passes through any arguments given. C can be customized, as described in L. =cut # This should make overriding behaviour of the Parser in subclasses easier: 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(@_); } { # of the following, anything beginning with an underscore is strictly # internal and should not be exposed. my %initialize = ( version => $DEFAULT_TAP_VERSION, plan => '', # the test plan (e.g., 1..3) tests_run => 0, # actual current test numbers skipped => [], # todo => [], # passed => [], # failed => [], # actual_failed => [], # how many tests really failed actual_passed => [], # how many tests really passed todo_passed => [], # tests which unexpectedly succeed parse_errors => [], # perfect TAP should have none ); # We seem to have this list hanging around all over the place. We could # probably get it from somewhere else to avoid the repetition. my @legal_callback = qw( test version plan comment bailout unknown yaml ALL ELSE EOF ); my @class_overrides = qw( grammar_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 # TAP::Parser::Iterator. # Shallow copy my %args = %{ $arg_for || {} }; $self->SUPER::_initialize( \%args, \@legal_callback ); # get any class overrides out first: for my $key (@class_overrides) { my $default_method = "_default_$key"; my $val = delete $args{$key} || $self->$default_method(); $self->$key($val); } my $iterator = delete $args{iterator}; $iterator ||= delete $args{stream}; # deprecated my $tap = delete $args{tap}; my $version = delete $args{version}; 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} || []; if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) { $self->_croak( "You may only choose one of 'exec', 'tap', 'source' or 'iterator'" ); } if ( my @excess = sort keys %args ) { $self->_croak("Unknown options: @excess"); } # convert $tap & $exec to $raw_source equiv. my $type = ''; my $source = TAP::Parser::Source->new; if ($tap) { $type = 'raw TAP'; $source->raw( \$tap ); } elsif ($exec) { $type = 'exec ' . $exec->[0]; $source->raw( { exec => $exec } ); } 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); } 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 ($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->version($version) if $version; $self->_iterator($iterator); $self->_spool($spool); $self->ignore_exit($ignore_exit); return $self; } } =head1 INDIVIDUAL RESULTS If you've read this far in the docs, you've seen this: while ( my $result = $parser->next ) { print $result->as_string; } Each result returned is a L subclass, referred to as I. =head2 Result types Basically, you fetch individual results from the TAP. The six types, with examples of each, are as follows: =over 4 =item * Version TAP version 12 =item * Plan 1..42 =item * Pragma pragma +strict =item * Test ok 3 - We should start with some foobar! =item * Comment # Hope we don't use up the foobar. =item * Bailout Bail out! We ran out of foobar! =item * Unknown ... yo, this ain't TAP! ... =back Each result fetched is a result object of a different type. There are common methods to each result object and different types may have methods unique to their type. Sometimes a type method may be overridden in a subclass, but its use is guaranteed to be identical. =head2 Common type methods =head3 C Returns the type of result, such as C or C. =head3 C Prints a string representation of the token. This might not be the exact output, however. Tests will have test numbers added if not present, TODO and SKIP directives will be capitalized and, in general, things will be cleaned up. If you need the original text for the token, see the C method. =head3 C Returns the original line of text which was parsed. =head3 C Indicates whether or not this is the test plan line. =head3 C Indicates whether or not this is a test line. =head3 C Indicates whether or not this is a comment. Comments will generally only appear in the TAP stream if STDERR is merged to STDOUT. See the C option. =head3 C Indicates whether or not this is bailout line. =head3 C Indicates whether or not the current item is a YAML block. =head3 C Indicates whether or not the current line could be parsed. =head3 C if ( $result->is_ok ) { ... } Reports whether or not a given result has passed. Anything which is B a test result returns true. This is merely provided as a convenient shortcut which allows you to do this: my $parser = TAP::Parser->new( { source => $source } ); while ( my $result = $parser->next ) { # only print failing results print $result->as_string unless $result->is_ok; } =head2 C methods if ( $result->is_plan ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C if ( $result->is_plan ) { print $result->plan; } This is merely a synonym for C. =head3 C my $directive = $result->directive; If a SKIP directive is included with the plan, this method will return it. 1..0 # SKIP: why bother? =head3 C my $explanation = $result->explanation; If a SKIP directive was included with the plan, this method will return the explanation, if any. =head2 C methods if ( $result->is_pragma ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C Returns a list of pragmas each of which is a + or - followed by the pragma name. =head2 C methods if ( $result->is_comment ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C if ( $result->is_comment ) { my $comment = $result->comment; print "I have something to say: $comment"; } =head2 C methods if ( $result->is_bailout ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C if ( $result->is_bailout ) { my $explanation = $result->explanation; print "We bailed out because ($explanation)"; } If, and only if, a token is a bailout token, you can get an "explanation" via this method. The explanation is the text after the mystical "Bail out!" words which appear in the tap output. =head2 C methods if ( $result->is_unknown ) { ... } There are no unique methods for unknown results. =head2 C methods if ( $result->is_test ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C my $ok = $result->ok; Returns the literal text of the C or C status. =head3 C my $test_number = $result->number; Returns the number of the test, even if the original TAP output did not supply that number. =head3 C my $description = $result->description; Returns the description of the test, if any. This is the portion after the test number but before the directive. =head3 C my $directive = $result->directive; Returns either C or C if either directive was present for a test line. =head3 C my $explanation = $result->explanation; If a test had either a C or C directive, this method will return the accompanying explanation, if present. not ok 17 - 'Pigs can fly' # TODO not enough acid For the above line, the explanation is I. =head3 C if ( $result->is_ok ) { ... } Returns a boolean value indicating whether or not the test passed. Remember that for TODO tests, the test always passes. B this was formerly C. The latter method is deprecated and will issue a warning. =head3 C if ( $result->is_actual_ok ) { ... } Returns a boolean value indicating whether or not the test passed, regardless of its TODO status. B this was formerly C. The latter method is deprecated and will issue a warning. =head3 C if ( $test->is_unplanned ) { ... } If a test number is greater than the number of planned tests, this method will return true. Unplanned tests will I return false for C, regardless of whether or not the test C (see L for more information about this). =head3 C if ( $result->has_skip ) { ... } Returns a boolean value indicating whether or not this test had a SKIP directive. =head3 C if ( $result->has_todo ) { ... } Returns a boolean value indicating whether or not this test had a TODO directive. Note that TODO tests I pass. If you need to know whether or not they really passed, check the C method. =head3 C if ( $parser->in_todo ) { ... } True while the most recent result was a TODO. Becomes true before the TODO result is returned and stays true until just before the next non- TODO test is returned. =head1 TOTAL RESULTS After parsing the TAP, there are many methods available to let you dig through the results and determine what is meaningful to you. =head2 Individual Results These results refer to individual tests which are run. =head3 C my @passed = $parser->passed; # the test numbers which passed my $passed = $parser->passed; # the number of tests which passed This method lets you know which (or how many) tests passed. If a test failed but had a TODO directive, it will be counted as a passed test. =cut sub passed { return @{ $_[0]->{passed} } if ref $_[0]->{passed}; return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{passed}; } =head3 C my @failed = $parser->failed; # the test numbers which failed my $failed = $parser->failed; # the number of tests which failed This method lets you know which (or how many) tests failed. If a test passed but had a TODO directive, it will B be counted as a failed test. =cut sub failed { @{ shift->{failed} } } =head3 C # the test numbers which actually passed my @actual_passed = $parser->actual_passed; # the number of tests which actually passed my $actual_passed = $parser->actual_passed; This method lets you know which (or how many) tests actually passed, regardless of whether or not a TODO directive was found. =cut sub actual_passed { return @{ $_[0]->{actual_passed} } if ref $_[0]->{actual_passed}; return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed}; } *actual_ok = \&actual_passed; =head3 C This method is a synonym for C. =head3 C # the test numbers which actually failed my @actual_failed = $parser->actual_failed; # the number of tests which actually failed my $actual_failed = $parser->actual_failed; This method lets you know which (or how many) tests actually failed, regardless of whether or not a TODO directive was found. =cut sub actual_failed { @{ shift->{actual_failed} } } ############################################################################## =head3 C my @todo = $parser->todo; # the test numbers with todo directives my $todo = $parser->todo; # the number of tests with todo directives This method lets you know which (or how many) tests had TODO directives. =cut sub todo { @{ shift->{todo} } } =head3 C # the test numbers which unexpectedly succeeded my @todo_passed = $parser->todo_passed; # the number of tests which unexpectedly succeeded my $todo_passed = $parser->todo_passed; This method lets you know which (or how many) tests actually passed but were declared as "TODO" tests. =cut sub todo_passed { @{ shift->{todo_passed} } } ############################################################################## =head3 C # deprecated in favor of 'todo_passed'. This method was horribly misnamed. This was a badly misnamed method. It indicates which TODO tests unexpectedly succeeded. Will now issue a warning and call C. =cut sub todo_failed { warn '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; goto &todo_passed; } =head3 C my @skipped = $parser->skipped; # the test numbers with SKIP directives my $skipped = $parser->skipped; # the number of tests with SKIP directives This method lets you know which (or how many) tests had SKIP directives. =cut sub skipped { @{ shift->{skipped} } } =head2 Pragmas =head3 C Get or set a pragma. To get the state of a pragma: if ( $p->pragma('strict') ) { # be strict } To set the state of a pragma: $p->pragma('strict', 1); # enable strict mode =cut sub pragma { my ( $self, $pragma ) = splice @_, 0, 2; return $self->{pragma}->{$pragma} unless @_; if ( my $state = shift ) { $self->{pragma}->{$pragma} = 1; } else { delete $self->{pragma}->{$pragma}; } return; } =head3 C Get a list of all the currently enabled pragmas: my @pragmas_enabled = $p->pragmas; =cut sub pragmas { sort keys %{ shift->{pragma} || {} } } =head2 Summary Results These results are "meta" information about the total results of an individual test program. =head3 C my $plan = $parser->plan; Returns the test plan, if found. =head3 C Deprecated. Use C instead. =cut sub good_plan { warn 'good_plan() is deprecated. Please use "is_good_plan()"'; goto &is_good_plan; } ############################################################################## =head3 C if ( $parser->is_good_plan ) { ... } Returns a boolean value indicating whether or not the number of tests planned matches the number of tests run. B this was formerly C. The latter method is deprecated and will issue a warning. And since we're on that subject ... =head3 C print $parser->tests_planned; Returns the number of tests planned, according to the plan. For example, a plan of '1..17' will mean that 17 tests were planned. =head3 C print $parser->tests_run; Returns the number of tests which actually were run. Hopefully this will match the number of C<< $parser->tests_planned >>. =head3 C Returns a true value (actually the reason for skipping) if all tests were skipped. =head3 C Returns the wall-clock time when the Parser was created. =head3 C Returns the wall-clock time when the end of TAP input was seen. =head3 C Returns the CPU times (like L when the Parser was created. =head3 C Returns the CPU times (like L when the end of TAP input was seen. =head3 C if ( $parser->has_problems ) { ... } This is a 'catch-all' method which returns true if any tests have currently failed, any TODO tests unexpectedly succeeded, or any parse errors occurred. =cut sub has_problems { my $self = shift; return $self->failed || $self->parse_errors || ( !$self->ignore_exit && ( $self->wait || $self->exit ) ); } =head3 C $parser->version; Once the parser is done, this will return the version number for the parsed TAP. Version numbers were introduced with TAP version 13 so if no version number is found version 12 is assumed. =head3 C $parser->exit; Once the parser is done, this will return the exit status. If the parser ran an executable, it returns the exit status of the executable. =head3 C $parser->wait; Once the parser is done, this will return the wait status. If the parser ran an executable, it returns the wait status of the executable. Otherwise, this merely returns the C status. =head2 C $parser->ignore_exit(1); Tell the parser to ignore the exit status from the test when determining whether the test passed. Normally tests with non-zero exit status are considered to have failed even if all individual tests passed. In cases where it is not possible to control the exit value of the test script use this option to ignore it. =cut sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) } =head3 C my @errors = $parser->parse_errors; # the parser errors my $errors = $parser->parse_errors; # the number of parser_errors Fortunately, all TAP output is perfect. In the event that it is not, this method will return parser errors. Note that a junk line which the parser does not recognize is C an error. This allows this parser to handle future versions of TAP. The following are all TAP errors reported by the parser: =over 4 =item * Misplaced plan The plan (for example, '1..5'), must only come at the beginning or end of the TAP output. =item * No plan Gotta have a plan! =item * More than one plan 1..3 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 read the rest of the file 1..3 Right. Very funny. Don't do that. =item * Test numbers out of sequence 1..3 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 2 read the rest of the file That last test line above should have the number '3' instead of '2'. Note that it's perfectly acceptable for some lines to have test numbers and others to not have them. However, when a test number is found, it must be in sequence. The following is also an error: 1..3 ok 1 - input file opened not ok - first line of the input valid # todo some data ok 2 read the rest of the file But this is not: 1..3 ok - input file opened not ok - first line of the input valid # todo some data ok 3 read the rest of the file =back =cut sub parse_errors { @{ shift->{parse_errors} } } sub _add_error { my ( $self, $error ) = @_; push @{ $self->{parse_errors} } => $error; return $self; } sub _make_state_table { my $self = shift; my %states; my %planned_todo = (); # These transitions are defaults for all states my %state_globals = ( comment => {}, bailout => {}, yaml => {}, version => { act => sub { $self->_add_error( 'If TAP version is present it must be the first line of output' ); }, }, unknown => { act => sub { my $unk = shift; if ( $self->pragma('strict') ) { $self->_add_error( 'Unknown TAP token: "' . $unk->raw . '"' ); } }, }, pragma => { act => sub { my ($pragma) = @_; for my $pr ( $pragma->pragmas ) { if ( $pr =~ /^ ([-+])(\w+) $/x ) { $self->pragma( $2, $1 eq '+' ); } } }, }, ); # Provides default elements for transitions my %state_defaults = ( plan => { act => sub { my ($plan) = @_; $self->tests_planned( $plan->tests_planned ); $self->plan( $plan->plan ); if ( $plan->has_skip ) { $self->skip_all( $plan->explanation || '(no reason given)' ); } $planned_todo{$_}++ for @{ $plan->todo_list }; }, }, test => { act => sub { my ($test) = @_; my ( $number, $tests_run ) = ( $test->number, ++$self->{tests_run} ); # Fake TODO state if ( defined $number && delete $planned_todo{$number} ) { $test->set_directive('TODO'); } my $has_todo = $test->has_todo; $self->in_todo($has_todo); if ( defined( my $tests_planned = $self->tests_planned ) ) { if ( $tests_run > $tests_planned ) { $test->is_unplanned(1); } } if ( defined $number ) { if ( $number != $tests_run ) { my $count = $tests_run; $self->_add_error( "Tests out of sequence. Found " . "($number) but expected ($count)" ); } } else { $test->_number( $number = $tests_run ); } push @{ $self->{todo} } => $number if $has_todo; push @{ $self->{todo_passed} } => $number if $test->todo_passed; push @{ $self->{skipped} } => $number if $test->has_skip; push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } => $number; push @{ $self->{ $test->is_actual_ok ? 'actual_passed' : 'actual_failed' } } => $number; }, }, yaml => { act => sub { }, }, ); # Each state contains a hash the keys of which match a token type. For # each token # type there may be: # act A coderef to run # goto The new state to move to. Stay in this state if # missing # continue Goto the new state and run the new state for the # current token %states = ( INIT => { version => { act => sub { my ($version) = @_; my $ver_num = $version->version; if ( $ver_num <= $DEFAULT_TAP_VERSION ) { my $ver_min = $DEFAULT_TAP_VERSION + 1; $self->_add_error( "Explicit TAP version must be at least " . "$ver_min. Got version $ver_num" ); $ver_num = $DEFAULT_TAP_VERSION; } if ( $ver_num > $MAX_TAP_VERSION ) { $self->_add_error( "TAP specified version $ver_num but " . "we don't know about versions later " . "than $MAX_TAP_VERSION" ); $ver_num = $MAX_TAP_VERSION; } $self->version($ver_num); $self->_grammar->set_version($ver_num); }, goto => 'PLAN' }, plan => { goto => 'PLANNED' }, test => { goto => 'UNPLANNED' }, }, PLAN => { plan => { goto => 'PLANNED' }, test => { goto => 'UNPLANNED' }, }, PLANNED => { test => { goto => 'PLANNED_AFTER_TEST' }, plan => { act => sub { my ($version) = @_; $self->_add_error( 'More than one plan found in TAP output'); }, }, }, PLANNED_AFTER_TEST => { test => { goto => 'PLANNED_AFTER_TEST' }, plan => { act => sub { }, continue => 'PLANNED' }, yaml => { goto => 'PLANNED' }, }, GOT_PLAN => { test => { act => sub { my ($plan) = @_; my $line = $self->plan; $self->_add_error( "Plan ($line) must be at the beginning " . "or end of the TAP output" ); $self->is_good_plan(0); }, continue => 'PLANNED' }, plan => { continue => 'PLANNED' }, }, UNPLANNED => { test => { goto => 'UNPLANNED_AFTER_TEST' }, plan => { goto => 'GOT_PLAN' }, }, UNPLANNED_AFTER_TEST => { test => { act => sub { }, continue => 'UNPLANNED' }, plan => { act => sub { }, continue => 'UNPLANNED' }, yaml => { goto => 'UNPLANNED' }, }, ); # Apply globals and defaults to state table for my $name ( keys %states ) { # Merge with globals my $st = { %state_globals, %{ $states{$name} } }; # Add defaults for my $next ( sort keys %{$st} ) { if ( my $default = $state_defaults{$next} ) { for my $def ( sort keys %{$default} ) { $st->{$next}->{$def} ||= $default->{$def}; } } } # Stuff back in table $states{$name} = $st; } return \%states; } =head3 C Get an a list of file handles which can be passed to C