Test-Harness-3.30000755001750001750 012240531220 13023 5ustar00leonleon000000000000Test-Harness-3.30/HACKING.pod000444001750001750 1427712240531220 14763 0ustar00leonleon000000000000 # 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.30/MANIFEST.CUMMULATIVE000444001750001750 1665212240531220 16135 0ustar00leonleon000000000000.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.30/Changes000444001750001750 12007612240531220 14521 0ustar00leonleon000000000000Revision history for Test-Harness 3.30 2013-11-12 - Fix missing parent prereq in META.{yml,json} and NotBuild.PL (Dagfinn Ilmari Mannsåker, #89650) - Respect PERL5LIB in tainting source handler test (Dagfinn Ilmari Mannsåker, Leon Timmermans) - Use base instead of parent: This dist is used for testing all other modules, so it should avoid having any non-core prerequisites. Having parent as a prereq leads to a circular dependency of parent -> Test::More -> Test::Harness. (Graham Knop) - Various POD fixes (Nathan Gary Glenn) - Don't localize all of %ENV in harness.t (Craig Berry) - Give TAP::Harness::Beyond a unique NAME (Leon Timmermans) 3.29 2013-08-10 - Get rid of use vars in favor of our in all modules (Leon Timmermans) and tests (Karen Etheridge) - Added use warnings to all modules (Leon Timmermans) and tests (Karen Etheridge) - Use parent instead of @ISA in all modules (Leon Timmermans) and tests (Karen Etheridge) - Fix failing test on VMS (Craig Berry) - Improve error message on loading failure (Leon Timmermans, #77730) - Use Text::ParseWords, deprecate TAP::Parser::Utils 3.28 2013-05-02 - Bugfix: Fix taint failures on Windows (Jan Dubois) 3.27 2013-04-30 - Dramatically reduce memory usage (Nick Clark, RT #84939) - Store test_num (in Grammar.pm) as a number instead of a string. Reduces memory usage (Nick Clark, RT #84939) - PERL5LIB is always propogated to a test's @INC, even with taint more (Schwern, RT #84377) - restore "always add -w to switches" behavior 3.26 2013-01-16 - Renamed env.opts.t to env_opts.t (for VMS) - Skipped some TAP::Formatter::HTML tests due to this bug: #82738 3.26 2012-06-05 - Rereleased to fix CPAN permission problem. No functional change. 3.24 2012-06-03 - RT #74393: corrected typo in M::B integration docs. - RT #63473: fix typo. - RT #49732: Attempt to load File::Glob::Windows to get correct glob semantics on Win32. - RT #47890: Don't use Win32::GetShortPathName. - RT #64404: Ignore textness ('-T') of script when reading shebang. - Handle the case where we don't know the wait status of the test more gracefully. - Make the test summary 'ok' line overrideable so that it can be changed to a plugin to make the output of prove idempotent. - Stop adding '-w' to perl switches by default - Apply upstream patch: http://perl5.git.perl.org/perl.git/commit \ /6359c64336d99060952232e7e300bd3c31afead8 In testargs.t in Test::Harness, don't run a world-writable file. The test writes a file, then changes the mode, then executes it. The file needs to be +x to be executable (on many platforms). The file will need to be +w to be deletable on some platforms. But setting the file world writable just before running it feels like a bad idea, given that the file's name is as predictable as process IDs, as there's a race condition to break into the account running perl's tests. 3.23 2011-02-20 - Merge in changes from core. Thanks BinGOs. - Made SourceHandler understand that an executable binary file is probably an executable. - Added workaround for Getopt::Long 2.25 handling of multivalue options. Fixes test failure on stock perl 5.6.2. 3.22 2010-08-14 - Allow TAP::Parser to recognize a nested BAIL_OUT directive. - Add brief HOWTO for creating and running pgTAP tests to TAP::Parser::SourceHandler::pgTAP. - Fix trailing plan + embedded YAML + TAP 13 case. Thanks to Steffen Schwigon. #54518. - Numerous spelling fixes. Thanks to Ville Skyttä. - Add new option --tapversion for prove to set the default assumed TAP version. Thanks to Steffen Schwigon. - Fixed tests to run successfully under Devel::Cover. Thanks to Phillipe Bruhat. - Fixed injection of test args to work with general executables as well as Perl scripts (#59186). - Allow multiple --ext=.foo arguments to prove, to allow running different types of tests in the same prove run. - App::Prove::extension() is now App::Prove::extensions(), and returns an arrayref of extensions, rather than a single scalar. The same change has been made to App::Prove::State::extension(). - Preserve old semantics for test scripts with a shebang line by favouring Perl as the intepreter for any file with a shebang (#59457). - Add --trap (summary on Ctrl-C) option to prove (#59427). - Removed TAP::Parser::SourceHandler::pgTAP. Find it in its own distribution on CPAN. - Source options to prove can now be specified so as to be passed to the source as a hash reference, eg: prove --source XYZ --xyz-option pset=foo=bar Ths "pset" option will be passed as a hash reference with the key "foo" and the value "bar". 3.21 2010-01-30 - Add test to ensure we're not depending on a module we no longer ship. - Fix up skip counts for Windows case - tests were failing on Windows. 3.20 2010-01-22 - Remove references / dependency on TAP::Parser::Source::Perl 3.19 2010-01-20 - Avoid depending on Module::Build. The resulting circular dependency made it impossible to install Test::Harness and/or Module::Build in some cases. 3.18 2010-01-19 - Handle the case where the filename of the perl executable contains space. Thanks to kmx. - Various documentation fixes. 3.17_04 2010-01-04 - Fix failures due to unknown location of Perl in t/source_handler.t. - Use EUMM style shebang magic to produce an executable 'psql' for t/source_handler.t. 3.17_03 2009-11-19 - Fix failures due to over-strict assertions in t/source.t. 3.17_02 2009-11-17 - Merge in Steve's missing changes. Oops. 3.17_01 2009-11-17 - Re-engineered source handling API to allow users to configure how TAP is sourced by the parser. Introduced a new 'sources' param to TAP::Harness, and new options to prove, eg: prove --source XYZ --xyz-option foo=bar The new TAP::Parser::SourceHandler API makes it much easier to write plugins. This breaks backwards compatibility for plugins & extenstions that rely on the following APIs: TAP::Parser::Source TAP::Parser::SourceFactory TAP::Parser::IteratorFactory TAP::Parser, specifically: new: 'source' & 'tap' params source_class perl_source_class iterator_factory_class make_source make_perl_source make_iterator Please see the TAP::Parser docs for more details. [Steve Purkis & David Wheeler] - Removed dependency on File::Spec [Schwern] - Made it possible to pass different args to each test [Lee Johnson] - Added HARNESS_SUBCLASS option to Test::Harness - Added TAP::Parser::SourceHandler::File which lets you to stream TAP from a text file (eg: *.tap). - Added TAP::Parser::SourceHandler::pgTAP. All the source handlers are new, but this is the only one to add major new functioality: the ability to run pgTAP tests (http://pgtap.projects.postgresql.org/). 3.17 2009-05-05 - Changed the 'failures' so that it is overridden by verbosity rather than the other way around. - Added the 'comments' option, most useful when used in conjunction with the 'failures' option. - Deprecated support for Perls earlier than 5.6.0. - Allow '-I lib' as well as '-Ilib' in $Test::Harness::Switches (regression). - Restore old skip parsing semantics for TAP < v13. Refs #39031. - Numerous small documentation fixes. - Remove support for fork-based parallel testing. Multiplexed parallel testing remains. 3.16 2009-02-19 - Fix path splicing on platforms where the path separator is not ':'. - Fixes/skips for failing Win32 tests. - Don't break with older CPAN::Reporter versions. 3.15 2009-02-17 - Refactor getter/setter generation into TAP::Object. - The App::Prove::State::Result::Test now stores the parser object. - After discussion with Andy, agreed to clean up the test output somewhat. t/foo.....ok becomes t/foo.t ... ok - Make Bail out! die instead of exiting. Dies with the same message as 2.64 for (belated) backwards compatibility. - Alex Vaniver's patch to refactor TAP::Formatter::Console into a new class, TAP::Formatter::File and a common base class: TAP::Formatter::Base. - Fix a bug where PERL5LIB might be put in the wrong spot in @INC. #40257 - Steve Purkis implemented a plugin mechanism for App::Prove. 3.14 2008-09-13 - Created a proper (ha!) API for prove state results and tests. - Added --count and --nocount options to prove to control X/Y display while running tests. - Added 'fresh' state option to run test scripts that have been touched since the test run. - fixed bug where PERL5OPT was not properly split - fixed regex in _filtered_inc. Fixes #39248. Thanks Slaven. 3.13 2008-07-27 - fixed various closure related leaks - made prove honour HARNESS_TIMER - Applied patches supplied by Alex Vandiver - add 'rules' switch to prove: allows parallel execution rules to be specified on the command line. - allow '**' (any path) wildcard in parallel rules - fix bug report address - make tprove_gtk example work again. 3.12 2008-06-22 - applied Steve Purkis' huge refactoring patch which adds configurable factories for most of the major internal classes. - applied David Wheeler's patch to allow exec to be a code reference. - made tests more robust in the presence of -MFoo in PERL5OPT. 3.11 2008-06-09 - applied Jim Keenan's patch that makes App::Prove::run return a rather than exit (#33609) - prove -r now recurses cwd rather than 't' by default (#33007) - restored --ext switch to prove (#33848) - added ignore_exit option to TAP::Parser and corresponding interfaces to TAP::Harness and Test::Harness. Requested for Parrot. - Implemented rule based parallel scheduler. - Moved filename -> display name mapping out of formatter. This prevents the formatter's strip-extensions logic from stripping extensions from supplied descriptions. - Only strip extensions from test names if all tests have the same extension. Previously we stripped extensions if all names had /any/ extension making it impossible to distinguish tests whose name differed only in the extension. - Removed privacy test that made it impossible to subclass TAP::Parser. - Delayed initialisation of grammar making it easier to replace the TAP::Parser stream after instantiation. - Make it possible to supply import parameters to a replacement harness with prove. - Make it possible to replace either _grammar /or/ _stream before reading from a TAP::Parser. 3.10 2008-02-26 - fix undefined value warnings with bleadperl. - added pragma support. - fault unknown TAP tokens under strict pragma. 3.09 2008-02-10 - support for HARNESS_PERL_SWITCHES containing things like '-e "system(shift)"'. - set HARNESS_IS_VERBOSE during verbose testing. - documentation fixes. 3.08 2008-02-08 - added support for 'out' option to Test::Harness::execute_tests. See #32476. Thanks RENEEB. - Fixed YAMLish handling of non-alphanumeric hash keys. - Added --dry option to prove for 2.64 compatibility. 3.07 2008-01-13 - prove now supports HARNESS_PERL_SWITCHES. - restored TEST_VERBOSE to prove. 3.06 2008-01-01 - Skip t/unicode.t if PERL_UNICODE set. Fixes #31731. Thanks Lukas. - App::Prove::State no longer complains about tests that are deleted. - --state=new and --state=old now consider the modification time of test scripts. - Made test suite core-compatible. 3.05 2007-12-09 - Skip unicode.t if Encode unavailable - Support for .proverc files. - Clarified prove documentation. 3.04 2007-12-02 - Fixed output leakage with really_quiet set. - Progress reports for tests without plans now show "143/?" instead of "143/0". - Made TAP::Harness::runtests support aliases for test names. - Made it possible to pass command line args to test programs from prove, TAP::Harness, TAP::Parser. - Added --state switch to prove. 3.03 2007-11-17 - Fixed some little bugs-waiting-to-happen inside TAP::Parser::Grammar. - Added parser_args callback to TAP::Harness. - Made @INC propagation even more compatible with 2.64 so that parrot still works *and* #30796 is fixed. 3.02 2007-11-15 - Process I/O now unbuffered, uses sysread, plays better with select. Fixes #30740. - Made Test::Harness @INC propagation more compatible with 2.64. Was breaking Parrot's test suite. - Added HARNESS_OPTIONS (#30676) 3.01 2007-11-12 - Fix for RHEL incpush.patch related failure. - Output real time of test completion with --timer - prove -b adds blib/auto to @INC - made SKIP plan parsing even more liberal for pre-v13 TAP 3.00 2007-11-06 - Non-dev release. No changes since 2.99_09. 2.99_09 2007-11-05 - Implemented TODO-in-PLAN syntax for TAP version 12 and earlier. 2.99_08 2007-11-04 - Tiny changes. New version pushed to get some smoke coverage. 2.99_07 2007-11-01 - Fix for #21938: Unable to handle circular links - Fix for #24926: prove -b and -l should use absolute paths - Fixed prove switches. Big oops. How the hell did we miss that? - Consolidated quiet, really_quiet, verbose into verbosity. - Various VMS related fixes to tests 2.99_06 2007-10-30 - Added skip_all method to TAP::Parser. - Display reason for skipped tests. - make test now self tests. 2.99_05 2007-10-30 - Fix for occasional rogue -1 exit code on Windows. - Fix for @INC handling under CPANPLUS. - Added real time to prove --timer output - Improved prove error message in case where 't' not found and no tests named. 2.99_04 2007-10-11 - Fixed bug where 'All tests successful' would not be printed if bonus tests are seen. - Fixed bug where 'Result: FAIL' would be printed at the end of a test run if there were unexpectedly succeeding tests. - Added -M, -P switches to allow arbitrary modules to be loaded by prove. We haven't yet defined what they'll do once they load but it's a start... - Added testing under simulated non-forking platforms. 2.99_03 2007-10-06 - Refactored all display specific code out of TAP::Harness. - Relaxed strict parsing of skip plan for pre v13 TAP. - Elapsed hi-res time is now displayed in integer milliseconds instead of fractional seconds. - prove stops running if any command-line switches are invalid. - prove -v would try to print an undef. - Added support for multiplexed and forked parallel tests. Use prove -j 9 to run tests in parallel and prove -j 9 --fork to fork. These features are experimental and currently unavailable on Windows. - Rationalized the management of the environment that we give to test scripts (PERL5LIB, PERL5OPT, switches). - Fixed handling of STDIN (we no longer close it) for test scripts. - Performance enhancements. Parser is now 30% - 40% faster. 2.99_02 2007-09-07 - Ensure prove (and App::Prove) sort any recursively discovered tests - It is now possible to register multiple callback handlers for a particular event. - Added before_runtests, after_runtests callbacks to TAP::Harness. - Moved logic of prove program into App::Prove. - Added simple machine readable summary. - Performance improvement: The processing pipeline within TAP::Parser is now a closure which speeds up access to the various attribtes it needs. - Performance improvement: Test count spinner now updates exponentially less frequently as the count increases which saves a lot of I/O on big tests. - More improvements in test coverage from Leif. - Fixes to TAP spooling - now captures YAML blocks correctly. - Fix YAMLish handling of empty arrays, hashes. - Renamed TAP::Harness::Compatible to Test::Harness, runtests to prove. - Fixes to @INC handling. We didn't always pass the correct path to subprocesses. - We now observe any switches in HARNESS_PERL_SWITCHES. - Changes to output formatting for greater compatibility with Test::Harness 2.64. - Added unicode test coverage and fixed a couple of unicode issues. - Additions to documentation. - Added support for non-forking Perls. If forking isn't available we fall back to open and disable stream merging. - Added support for simulating non-forking Perls to improve our test coverage. ======================================================================== Version numbers below this point relate to TAP::Parser - which was the name of this version of Test::Harness during its development. ======================================================================== 0.54 - Optimized I/O for common case of 'runtests -l' - Croak if supplied an empty (0 lines) Perl script. - Made T::P::Result::YAML return literal input YAML correctly. - Merged speed-ups from speedy branch. 0.53 18 August 2007 - Fixed a few docs nits. - Added -V (--version) switch to runtests. Suggested by markjugg on Perlmonks. - Fixed failing t/030-grammer.t under 5.9.5. Exact cause still unknown; something to do with localisation of $1 et all I think. - Fixed use of three arg open in t/compat/test-harness-compat; was failing on 5.6.2. - Fixed runtests --exec option. T::H wasn't passing the exec option to T::P. - Merged Leif Eriksen's coverage enhancing changes to t/080-aggregator.t, t/030-grammar.t - Made various changes so that we test cleanly on 5.0.5. - Many more coverage enhancements by Leif. - Applied Michael Peters' patch to add an EOF callback to TAP::Parser. - Added --reverse option to runtests to run tests in reverse order. - Made runtests exit with non-zero status if the test run had problems. - Stopped TAP::Parser::Iterator::Process from trampling on STDIN. 0.52 14 July 2007 - Incorporate Schwern's investigations into TAP versions. Unversioned TAP is now TAP v12. The lowest explicit version number that can be specified is 13. - Renumbered tests to eliminate gaps. - Killed execrc. The '--exec' switch to runtests handles all of this for us. - Refactored T::P::Iterator into T::P::Iterator::(Array|Process|Stream) so that we have a process specific iterator with which to experiment with STDOUT/STDERR merging. - Removed vestigial exit status handling from T::P::I::Stream. - Removed unused pid interface from T::P::I::Process. - Fixed infinite recursion in T::P::I::Stream and added regression coverage for same. - Added tests for T::P::I::Process. - TAP::Harness now displays the first five TAP syntax errors and explains how to pass the -p flag to runtests to see them all. - Added merge option to TAP::Parser::Iterator::Process, TAP::Parser::Source, TAP::Parser and TAP::Harness. - Added --merge option to runtests to enable STDOUT/STDERR merging. This behaviour used to be the default. - Made T::P::I::Process use open3 for both merged and non-merged streams so that it works on Windows. - Implemented Eric Wilhelm's IO::Select based multiple stream handler so that STDERR is piped to us even if stream merging is turned off. This tends to reduce the temporal skew between the two streams so that error messages appear closer to their correct location. - Altered the T::P::Grammar interface so that it gets a stream rather than the next line from the stream in preparation for making it handle YAML diagnostics. - Implemented YAML syntax. Currently YAML may only follow a test result. The first line of YAML is '---' and the last line is '...'. - Made grammar version-aware. Different grammars may now be selected depending on the TAP version being parsed. - Added formatter delegate mechanism for test results. - Added prototype stream based YAML(ish) parser. - Added more tests for T::P::YAMLish - Altered T::P::Grammar to use T::P::YAMLish - Removed T::P::YAML - Added raw source capture to T::P::YAMLish - Added support for double quoted hash keys - Added TAP::Parser::YAMLish::Writer and renamed T::P::YAMLish as T::P::YAMLish::Reader. - Added extra TAP::Parser::YAMLish::Writer output options - Inline YAML documents must now be indented by at least one space - Fixed broken dependencies in bin/prove - Make library paths absolute before running tests in case tests chdir before loading modules. - Added libs and switches handling to T::H::Compatible. This and the previous change fix [24926] - Added PERLLIB to libraries stripped in _default_inc [12030] - Our version of prove now handles directories containing circular links correctly [21938] - Set TAP_VERSION env var in Parser [11595] - Added setup, teardown hooks to T::P::I::Process to facilitate the setup and cleanup of the test script's environment - Any additional libs added to the command line are also added to PERL5LIB for the duration of a test run so that any Perl children of the test script inherit the same library paths. - Fixed handling of single quoted hash keys in T::P::Y::Reader - Made runtests return the TAP::Parser::Aggregator - Fixed t/120-harness.t has failures if TAP::Harness::Color cannot load optional modules [27125] - thanks DROLSKY - Fixed parsing of \# in test description 0.51 12 March 2007 - 'execrc' file now allows 'regex' matches for tests. - rename 'TAPx' --> 'TAP' - Reimplemented the parse logic of TAP::Parser as a state machine. - Removed various ad-hoc state variables from TAP::Parser and moved their logic into the state machine. - Removed now-unused is_first / is_last methods from Iterator and simplified remaining logic to suit. - Removed now-redundant t/140-varsource.t. - Implemented TAP version syntax. - Tidied TAP::Harness::Compatible documentation - Removed redundant modules below TAP::Harness::Compatible - Removed unused compatibility tests 0.50_07 5 March 2007 - Fixed bug where we erroneously checked the test number instead of number of tests run to determine if we've run more tests than we planned. - Add a --directives switch to 'runtests' which only shows test results with directives (such as 'TODO' or 'SKIP'). - Removed some dead code from TAPx::Parser. - Added color support for Windows using Win32::Console. - Made Color::failure_output reset colors before printing the trailing newline. - Corrected some issues with the 'runtests' docs and removed some performance notes which no longer seem accurate. - Fixed bug whereby if tests without file extensions were included then the spacing of the result leaders would be off. - execrc file is now a YAML file. - Removed white background on the test failures. It was too garish for me. Just more proof that we need better ways of overriding color support. - Started work on TAPx::Harness::Compatible. Right now it's mainly just a direct lift of Test::Harness to make sure the tests work. - Commented out use Data::Dumper::Simple in T::Harness.pm - it's not a core module. - Added next_raw to TAPx::Parser::Iterator which skips any fixes for quirky TAP that are implemented by next. Used to support TAPx::Harness::Compatible::Iterator - Applied our version number to all T::H::Compatible modules - Removed T::H::C::Assert. It's documented as being private to Test::Harness and we're not going to need it. - Refactored runtests to call aggregate_tests to expose the interface we need for the compatibility layer. - Make it possible to pass an end time to summary so that it needn't be called immediately after the tests complete. - Moved callback handling into TAPx::Base and altered TAPx::Parser to use it. - Made TAPx::Harness into a subclass of TAPx::Base and implemented made_parser callback. - Moved the dispatch of callbacks out of run and into next so that they're called when TAPx::Harness iterates through the results. - Implemented PERL_TEST_HARNESS_DUMP_TAP which names a directory into which the raw TAP of any tests run via TAPx::Harness will be written. - Rewrote the TAPx::Grammar->tokenize method to return a TAPx::Parser::Result object. Code is much cleaner now. - Moved the official grammar from TAPx::Parser to TAPx::Parser::Grammar, provided a link and updated the grammar. - Fixed bug where a properly escaped '# TODO' line in a test description would still be reported as a TODO test. - Added patches/ExtUtils-MakeMaker-6.31.patch - a patch against EUMM that makes test_harness use TAPx::Harness instead of Test::Harness if PERL_EUMM_USE_TAPX is true and TAPx::Harness is installed. In other words cause 'make test' for EUMM based models to use TAPx::Harness. - Added support for timer option to TAPx::Harness which causes the elapsed time for each test to be displayed. - Setup tapx-dev@hexten.net mailing list. - Fixed accumulating @$exec bug in TAPx::Harness. - Made runtests pass '--exec' option as an array. - (#24679) TAPx::Harness now reports failure for tests that die after completing all subtests. - Added in_todo attribute on TAPx::Parser which is true while the most recently seen test was a TODO. - (#24728) TAPx::Harness now supresses diagnostics from failed TODOs. Not sure if the semantics of this are correct yet. 0.50_06 18 January 2007 - Fixed doc typo in examples/README [rt.cpan.org #24409] - Colored test output is now the default for 'runtests' unless you're running under windows or -t STDOUT is false. [rt.cpan.org #24310] - Removed the .t extension from t/source_tests/*.t since those are 'test tests' which caused false negatives when running recursive tests. [Adrian Howard] - Somewhere along the way, the exit status started working again. Go figure. - Factored color output so that disabling it under Windows is cleaner. - Added explicit switch to :crlf layer after open3 under Windows. open3 defaults to raw mode resulting in spurious \r characters input parsed input. - Made Iterator do an explicit wait for subprocess termination. Needed to get process status correctly on Windows. - Fixed bug which didn't allow t/010-regression.t to be run directly via Perl unless you specified Perl's full path. - Removed SIG{CHLD} handler (which we shouldn't need I think because we explicitly waitpid) and made binmode ':crlf' conditional on IS_WIN32. On Mac OS these two things combined to expose a problem which meant that output from test scripts was sometimes lost. - Made t/110-source.t use File::Spec->catfile to build path to test script. - Made Iterator::FH init is_first, is_last to 0 rather than undef for consistency with array iterator. - Added t/120-varsource.t to test is_first and is_last semantics over files with small numbers of lines. - Added check for valid callback keys. - Added t/130-results.t for Result classes. 0.50_05 15 January 2007 - Removed debugging code accidentally left in bin/runtests. - Removed 'local $/ = ...' from the iterator. Hopefully that will fix the line ending bug, but I don't know about the wstat problem. 0.50_04 14 January 2007 - BACKWARDS IMCOMPATIBLE: Renamed all '::Results' classes to '::Result' because they represent a single result. - Fixed bug where piping would break verbose output. - IPC::Open3::open3 now takes a @command list rather than a $command string. This should make it work under Windows. - Added 'stdout_sterr' sample test back to regression tests. IPC::Open3 appears to make it work. - Bug fix: don't print 'All tests successful' if no tests are run. - Refactored 'runtests' to make it a bit easier to follow. - Bug fix: Junk and comments now allowed before a leading plan. - HARNESS_ACTIVE and HARNESS_VERSION environment variables now set. - Renamed 'problems' in TAPx::Parser and TAPx::Aggregator to 'has_problems'. 0.50_03 08 January 2007 - Fixed bug where '-q' or '-Q' with colored tests weren't suppressing all information. - Fixed an annoying MANIFEST nit. - Made '-h' for runtests now report help. Using a new harness requires the full --harness switch. - Added 'problems' method to TAPx::Parser and TAPx::Parser::Aggregator. - Deprecatd 'todo_failed' in favor of 'todo_passed' - Add -I switch to runtests. - Fixed runtests doc nit (smylers) - Removed TAPx::Parser::Builder. - A few more POD nits taken care of. - Completely removed all traces of C<--merge> as IPC::Open3 seems to be working. - Moved the tprove* examples to examples/bin in hopes of them no longer showing up in CPAN's docs. - Made the 'unexpectedly succeeded' message clearer (Adam Kennedy) 0.50_02 06 January 2007 - Added some files I left out of the manifest (reported by Florian Ragwitz). - Added strict to Makefile.PL and changed @PROGRAM to @program (reported Florian Ragwitz). 0.50_01 06 January 2007 - Added a new example which shows to how test Perl, Ruby, and URLs all at the same time using 'execrc' files. - Fixed the diagnostic format mangling bug. - We no longer override Test::Builder to merge streams. Instead, we go ahead and use IPC::Open3. It remains to be seen whether or not this is a good idea. - Fixed vms nit: for failing tests, vms often has the 'not' on a line by itself. - Fixed bugs where unplanned tests were not reporting as a failure (test number greater than tests planned). - TAPx::Parser constructor can now take an 'exec' option to tell it what to execute to create the stream (huge performance boost). - Added TAPx::Parser::Source. This allows us to run tests in just about any programming language. - Renamed the filename() method to source() in TAPx::Parser::Source::Perl. - We now cache the @INC values found for TAPx::Parser::Source::Perl. - Added two test harnesses, TAPx::Harness and TAPx::Harness::Color. - Removed references to manual stream construction from TAPx::Parser documentation. Users should not (usually) need to worry about streams. - Added bin/runtests utility. This is very similar to 'prove'. - Renumbered tests to make it easier to add new ones. - Corrected some minor documentation nits. - Makefile.PL is no longer auto-generated (it's built by hand). - Fixed regression test bug where driving tests through the harness I'm testing caused things to break. - BUG: exit() values are now broken. I don't know how to capture them with IPC::Open3. However, since no one appears to be using them, this might not be an issue. 0.41 12 December 2006 - Fixed (?) 10-regression.t test which failed on Windows. Removed the segfault test as it has no meaning on Windows. Reported by PSINNOTT and fix recommended by Schwern based on his Test::Harness experience. http://rt.cpan.org/Ticket/Display.html?id=21624 0.40 05 December 2006 - Removed TAPx::Parser::Streamed and folded its functionality into TAPx::Parser. - Fixed bug where sometimes is_good_plan() would return a false positive (exposed by refactoring). - A number of tiny performance enhancements. 0.33 22 September 2006 - OK, I'm getting ticked off by some of the comments on Perl-QA so I rushed this out the door and broke it :( I'm backing out one test and slowing down a bit. 0.32 22 September 2006 - Applied patch from Schwern which fixed the Builder package name (TAPx:: instead of TAPX:: -- stupid case-insensitive package names!). [rt.cpan.org #21605] 0.31 21 September 2006 - Fixed bug where Carp::croak without parens could cause Perl to fail to compile on some platforms. [Andreas J. Koenig] - Eliminated the non-portable redirect of STDERR to STDOUT (2>&1) and fixed the synchronization issue. This involves overridding Test::Builder::failure_output() in a very sneaky way. I may have to back this out. - Renamed boolean methods to begin with 'is_'. The methods they replace are documented, deprecated, and will not be removed prior to version 1.00. 0.30 17 September 2006 - Fixed bug where no output would still claim to have a good plan. - Fixed bug where no output would cause parser to die. - Fixed bug where failing to specify a plan would be two parse errors instead of one. - Fixed bug where a correct plan count in an incorrect place would still report as a 'good_plan'. - Fixed bug where comments could accidently be misparsed as directives. - Eliminated testing of internal structure of result objects. The other tests cover this. - Allow hash marks in descriptions. This was causing a problem because many test suites (Regexp::Common and Perl core) allowed them to exist. - Added support for SKIP directives in plans. - Did some work simplifying &TAPx::Parser::_initialize. It's not great, but it's better than it was. - TODO tests now always pass, regardless of actual_passed status. - Removed 'use warnings' and now use -w - 'switches' may now be passed to the TAPx::Parser constructor. - Added 'exit' status. - Added 'wait' status. - Eliminated 'use base'. This is part of the plan to make TAPx::Parser compatible with older versions of Perl. - Added 'source' key to the TAPx::Parser constructor. Making new parsers is now much easier. - Renamed iterator first() and last() methods to is_first() and is_last(). Credit: Aristotle. - Planned tests != tests run is now a parse error. It was really stupid of me not to do that in the first place. - Added massive regression test suite in t/100-regression.t - Updated the grammar to show that comments are allowed. - Comments are now permitted after an ending plan. 0.22 13 September 2006 - Removed buggy support for multi-line chunks from streams. If your streams or iterators return anything but single lines, this is a bug. - Fixed bug whereby blank lines in TAP would confuse the parser. Reported by Torsten Schoenfeld. - Added first() and last() methods to the iterator. - TAPx::Parser::Source::Perl now has a 'switches' method which allows switches to be passed to the perl executable running the test file. This allows tprove to accept a '-l' argument to force lib/ to be included in Perl's @INC. 0.21 8 September 2006 - Included experimental GTK interface written by Torsten Schoenfeld. - Fixed bad docs in examples/tprove_color - Applied patch from Shlomi Fish fixing bug where runs from one stream could leak into another when bailing out. [rt.cpan.org #21379] - Fixed some typos in the POD. - Corrected the grammar to allow for a plan of "1..0" (infinite stream). - Started to add proper acknowledgements. 0.20 2 September 2006 - Fixed bug reported by GEOFFR. When no tap output was found, an "Unitialized value" warning occurred. [rt.cpan.org #21205] - Updated tprove to now report a test failure when no tap output found. - Removed examples/tprove_color2 as tprove_color now works. - Vastly improved callback system and updated the docs for how to use them. - Changed TAPx::Parser::Source::Perl to use Symbol::gensym() instead of a hard-to-guess filehandle name. 0.12 30 July 2006 - Added a test colorization script - Callback support added. - Added TAPx::Parser::Source::Perl. - Added TAPx::Parser::Aggregator. - Added version numbers to all classes. - Added 'todo_failed' test result and parser. - 00-load.t now loads all classes instead of having individual tests load their supporting classes. - Changed $parser->results to $parser->next 0.11 25 July, 2006 - Renamed is_skip and is_todo to has_skip and has_todo. Much less confusing since a result responding true to those also responded true to is_test. - Added simplistic bin/tprove to run tests. Much harder than I thought and much code stolen from Test::Harness. - Modified stolen iterator to fix a bug with stream handling when extra newlines were encountered. - Added TAPx::Parser::Iterator (stolen from Test::Harness::Iterator) - Normalized internal structure of result objects. - All tokens now have a 'type' key. This greatly simplifies internals. - Copied much result POD info into the main docs. - Corrected the bug report URLs. - Minor updates to the grammar listed in the POD. 0.10 23 July, 2006 - Oh my Larry, we gots docs! - _parse and _tap are now private methods. - Stream support has been added. - Moved the grammar into its own class. - Pulled remaining parser functionality out of lexer. - Added type() method to Results(). - Parse errors no longer croak(). Instead, they are available through the parse_errors() method. - Added good_plan() method. - tests_planned != tests_run is no longer a parse error. - Renamed test_count() to tests_run(). - Renamed num_tests() to tests_planned(). 0.03 17 July, 2006 - 'Bail out!' is now handled. - The parser is now data driven, thus skipping a huge if/else chain - We now track all TODOs, SKIPs, passes and fails by test number. - Removed all non-core modules. - Store original line for each TAP line. Available through $result->raw(). - Renamed test is_ok() to passed() and added actual_passed(). The former method takes into account TODO tests and the latter returns the actual pass/fail status. - Fixed a bug where SKIP tests would not be identified correctly. 0.02 8 July, 2006 - Moved some lexer responsibility to the parser. This will allow us to eventually parse streams. - Properly track passed/failed tests, even accounting for TODO. - Added support for comments and unknown lines. - Allow explicit and inferred test numbers to be mixed. - Allow escaped hashes in the test description. - Renamed to TAPx::Parser. Will probably rename it again. 0.01 Date/time - First version, unreleased on an unsuspecting world. - No, you'll never know when ... Test-Harness-3.30/META.json000444001750001750 1577212240531220 14635 0ustar00leonleon000000000000{ "abstract" : "Run Perl standard test scripts with statistics", "author" : [ "Andy Armstrong C<< >>" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4007, CPAN::Meta::Converter version 2.132830", "keywords" : [ "TAP", "test harness", "prove" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Harness", "prereqs" : { "runtime" : { "recommends" : { "Pod::Usage" : "1.12" } } }, "provides" : { "App::Prove" : { "file" : "lib/App/Prove.pm", "version" : "3.30" }, "App::Prove::State" : { "file" : "lib/App/Prove/State.pm", "version" : "3.30" }, "App::Prove::State::Result" : { "file" : "lib/App/Prove/State/Result.pm", "version" : "3.30" }, "App::Prove::State::Result::Test" : { "file" : "lib/App/Prove/State/Result/Test.pm", "version" : "3.30" }, "TAP::Base" : { "file" : "lib/TAP/Base.pm", "version" : "3.30" }, "TAP::Formatter::Base" : { "file" : "lib/TAP/Formatter/Base.pm", "version" : "3.30" }, "TAP::Formatter::Color" : { "file" : "lib/TAP/Formatter/Color.pm", "version" : "3.30" }, "TAP::Formatter::Console" : { "file" : "lib/TAP/Formatter/Console.pm", "version" : "3.30" }, "TAP::Formatter::Console::ParallelSession" : { "file" : "lib/TAP/Formatter/Console/ParallelSession.pm", "version" : "3.30" }, "TAP::Formatter::Console::Session" : { "file" : "lib/TAP/Formatter/Console/Session.pm", "version" : "3.30" }, "TAP::Formatter::File" : { "file" : "lib/TAP/Formatter/File.pm", "version" : "3.30" }, "TAP::Formatter::File::Session" : { "file" : "lib/TAP/Formatter/File/Session.pm", "version" : "3.30" }, "TAP::Formatter::Session" : { "file" : "lib/TAP/Formatter/Session.pm", "version" : "3.30" }, "TAP::Harness" : { "file" : "lib/TAP/Harness.pm", "version" : "3.30" }, "TAP::Harness::Env" : { "file" : "lib/TAP/Harness/Env.pm", "version" : "3.30" }, "TAP::Object" : { "file" : "lib/TAP/Object.pm", "version" : "3.30" }, "TAP::Parser" : { "file" : "lib/TAP/Parser.pm", "version" : "3.30" }, "TAP::Parser::Aggregator" : { "file" : "lib/TAP/Parser/Aggregator.pm", "version" : "3.30" }, "TAP::Parser::Grammar" : { "file" : "lib/TAP/Parser/Grammar.pm", "version" : "3.30" }, "TAP::Parser::Iterator" : { "file" : "lib/TAP/Parser/Iterator.pm", "version" : "3.30" }, "TAP::Parser::Iterator::Array" : { "file" : "lib/TAP/Parser/Iterator/Array.pm", "version" : "3.30" }, "TAP::Parser::Iterator::Process" : { "file" : "lib/TAP/Parser/Iterator/Process.pm", "version" : "3.30" }, "TAP::Parser::Iterator::Stream" : { "file" : "lib/TAP/Parser/Iterator/Stream.pm", "version" : "3.30" }, "TAP::Parser::IteratorFactory" : { "file" : "lib/TAP/Parser/IteratorFactory.pm", "version" : "3.30" }, "TAP::Parser::Multiplexer" : { "file" : "lib/TAP/Parser/Multiplexer.pm", "version" : "3.30" }, "TAP::Parser::Result" : { "file" : "lib/TAP/Parser/Result.pm", "version" : "3.30" }, "TAP::Parser::Result::Bailout" : { "file" : "lib/TAP/Parser/Result/Bailout.pm", "version" : "3.30" }, "TAP::Parser::Result::Comment" : { "file" : "lib/TAP/Parser/Result/Comment.pm", "version" : "3.30" }, "TAP::Parser::Result::Plan" : { "file" : "lib/TAP/Parser/Result/Plan.pm", "version" : "3.30" }, "TAP::Parser::Result::Pragma" : { "file" : "lib/TAP/Parser/Result/Pragma.pm", "version" : "3.30" }, "TAP::Parser::Result::Test" : { "file" : "lib/TAP/Parser/Result/Test.pm", "version" : "3.30" }, "TAP::Parser::Result::Unknown" : { "file" : "lib/TAP/Parser/Result/Unknown.pm", "version" : "3.30" }, "TAP::Parser::Result::Version" : { "file" : "lib/TAP/Parser/Result/Version.pm", "version" : "3.30" }, "TAP::Parser::Result::YAML" : { "file" : "lib/TAP/Parser/Result/YAML.pm", "version" : "3.30" }, "TAP::Parser::ResultFactory" : { "file" : "lib/TAP/Parser/ResultFactory.pm", "version" : "3.30" }, "TAP::Parser::Scheduler" : { "file" : "lib/TAP/Parser/Scheduler.pm", "version" : "3.30" }, "TAP::Parser::Scheduler::Job" : { "file" : "lib/TAP/Parser/Scheduler/Job.pm", "version" : "3.30" }, "TAP::Parser::Scheduler::Spinner" : { "file" : "lib/TAP/Parser/Scheduler/Spinner.pm", "version" : "3.30" }, "TAP::Parser::Source" : { "file" : "lib/TAP/Parser/Source.pm", "version" : "3.30" }, "TAP::Parser::SourceHandler" : { "file" : "lib/TAP/Parser/SourceHandler.pm", "version" : "3.30" }, "TAP::Parser::SourceHandler::Executable" : { "file" : "lib/TAP/Parser/SourceHandler/Executable.pm", "version" : "3.30" }, "TAP::Parser::SourceHandler::File" : { "file" : "lib/TAP/Parser/SourceHandler/File.pm", "version" : "3.30" }, "TAP::Parser::SourceHandler::Handle" : { "file" : "lib/TAP/Parser/SourceHandler/Handle.pm", "version" : "3.30" }, "TAP::Parser::SourceHandler::Perl" : { "file" : "lib/TAP/Parser/SourceHandler/Perl.pm", "version" : "3.30" }, "TAP::Parser::SourceHandler::RawTAP" : { "file" : "lib/TAP/Parser/SourceHandler/RawTAP.pm", "version" : "3.30" }, "TAP::Parser::YAMLish::Reader" : { "file" : "lib/TAP/Parser/YAMLish/Reader.pm", "version" : "3.30" }, "TAP::Parser::YAMLish::Writer" : { "file" : "lib/TAP/Parser/YAMLish/Writer.pm", "version" : "3.30" }, "Test::Harness" : { "file" : "lib/Test/Harness.pm", "version" : "3.30" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness" }, "homepage" : "http://testanything.org/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/Perl-Toolchain-Gang/Test-Harness/tree/master" }, "x_MailingList" : "mailto:" }, "version" : "3.30" } Test-Harness-3.30/META.yml000444001750001750 1145412240531220 14456 0ustar00leonleon000000000000--- abstract: 'Run Perl standard test scripts with statistics' author: - 'Andy Armstrong C<< >>' build_requires: {} dynamic_config: 1 generated_by: 'Module::Build version 0.4007, CPAN::Meta::Converter version 2.132830' keywords: - TAP - 'test harness' - prove license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-Harness provides: App::Prove: file: lib/App/Prove.pm version: 3.30 App::Prove::State: file: lib/App/Prove/State.pm version: 3.30 App::Prove::State::Result: file: lib/App/Prove/State/Result.pm version: 3.30 App::Prove::State::Result::Test: file: lib/App/Prove/State/Result/Test.pm version: 3.30 TAP::Base: file: lib/TAP/Base.pm version: 3.30 TAP::Formatter::Base: file: lib/TAP/Formatter/Base.pm version: 3.30 TAP::Formatter::Color: file: lib/TAP/Formatter/Color.pm version: 3.30 TAP::Formatter::Console: file: lib/TAP/Formatter/Console.pm version: 3.30 TAP::Formatter::Console::ParallelSession: file: lib/TAP/Formatter/Console/ParallelSession.pm version: 3.30 TAP::Formatter::Console::Session: file: lib/TAP/Formatter/Console/Session.pm version: 3.30 TAP::Formatter::File: file: lib/TAP/Formatter/File.pm version: 3.30 TAP::Formatter::File::Session: file: lib/TAP/Formatter/File/Session.pm version: 3.30 TAP::Formatter::Session: file: lib/TAP/Formatter/Session.pm version: 3.30 TAP::Harness: file: lib/TAP/Harness.pm version: 3.30 TAP::Harness::Env: file: lib/TAP/Harness/Env.pm version: 3.30 TAP::Object: file: lib/TAP/Object.pm version: 3.30 TAP::Parser: file: lib/TAP/Parser.pm version: 3.30 TAP::Parser::Aggregator: file: lib/TAP/Parser/Aggregator.pm version: 3.30 TAP::Parser::Grammar: file: lib/TAP/Parser/Grammar.pm version: 3.30 TAP::Parser::Iterator: file: lib/TAP/Parser/Iterator.pm version: 3.30 TAP::Parser::Iterator::Array: file: lib/TAP/Parser/Iterator/Array.pm version: 3.30 TAP::Parser::Iterator::Process: file: lib/TAP/Parser/Iterator/Process.pm version: 3.30 TAP::Parser::Iterator::Stream: file: lib/TAP/Parser/Iterator/Stream.pm version: 3.30 TAP::Parser::IteratorFactory: file: lib/TAP/Parser/IteratorFactory.pm version: 3.30 TAP::Parser::Multiplexer: file: lib/TAP/Parser/Multiplexer.pm version: 3.30 TAP::Parser::Result: file: lib/TAP/Parser/Result.pm version: 3.30 TAP::Parser::Result::Bailout: file: lib/TAP/Parser/Result/Bailout.pm version: 3.30 TAP::Parser::Result::Comment: file: lib/TAP/Parser/Result/Comment.pm version: 3.30 TAP::Parser::Result::Plan: file: lib/TAP/Parser/Result/Plan.pm version: 3.30 TAP::Parser::Result::Pragma: file: lib/TAP/Parser/Result/Pragma.pm version: 3.30 TAP::Parser::Result::Test: file: lib/TAP/Parser/Result/Test.pm version: 3.30 TAP::Parser::Result::Unknown: file: lib/TAP/Parser/Result/Unknown.pm version: 3.30 TAP::Parser::Result::Version: file: lib/TAP/Parser/Result/Version.pm version: 3.30 TAP::Parser::Result::YAML: file: lib/TAP/Parser/Result/YAML.pm version: 3.30 TAP::Parser::ResultFactory: file: lib/TAP/Parser/ResultFactory.pm version: 3.30 TAP::Parser::Scheduler: file: lib/TAP/Parser/Scheduler.pm version: 3.30 TAP::Parser::Scheduler::Job: file: lib/TAP/Parser/Scheduler/Job.pm version: 3.30 TAP::Parser::Scheduler::Spinner: file: lib/TAP/Parser/Scheduler/Spinner.pm version: 3.30 TAP::Parser::Source: file: lib/TAP/Parser/Source.pm version: 3.30 TAP::Parser::SourceHandler: file: lib/TAP/Parser/SourceHandler.pm version: 3.30 TAP::Parser::SourceHandler::Executable: file: lib/TAP/Parser/SourceHandler/Executable.pm version: 3.30 TAP::Parser::SourceHandler::File: file: lib/TAP/Parser/SourceHandler/File.pm version: 3.30 TAP::Parser::SourceHandler::Handle: file: lib/TAP/Parser/SourceHandler/Handle.pm version: 3.30 TAP::Parser::SourceHandler::Perl: file: lib/TAP/Parser/SourceHandler/Perl.pm version: 3.30 TAP::Parser::SourceHandler::RawTAP: file: lib/TAP/Parser/SourceHandler/RawTAP.pm version: 3.30 TAP::Parser::YAMLish::Reader: file: lib/TAP/Parser/YAMLish/Reader.pm version: 3.30 TAP::Parser::YAMLish::Writer: file: lib/TAP/Parser/YAMLish/Writer.pm version: 3.30 Test::Harness: file: lib/Test/Harness.pm version: 3.30 recommends: Pod::Usage: 1.12 resources: MailingList: mailto: bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness homepage: http://testanything.org/ license: http://dev.perl.org/licenses/ repository: http://github.com/Perl-Toolchain-Gang/Test-Harness/tree/master version: 3.30 Test-Harness-3.30/MANIFEST000444001750001750 1251312240531220 14333 0ustar00leonleon000000000000bin/prove Changes Changes-2.64 examples/analyze_tests.pl examples/bin/forked_tests.pl examples/bin/test_html.pl examples/bin/tprove_gtk examples/harness-hook/hook.pl examples/harness-hook/lib/Harness/Hook.pm examples/my_exec examples/README examples/silent-harness.pl examples/t/10-stuff.t examples/t/ruby.t examples/test_urls.txt HACKING.pod 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/Env.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/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/YAMLish/Reader.pm lib/TAP/Parser/YAMLish/Writer.pm lib/Test/Harness.pm Makefile.PL MANIFEST MANIFEST.CUMMULATIVE META.yml NotBuild.PL perlcriticrc README t/000-load.t t/aggregator.t t/bailout.t t/base.t t/callbacks.t t/compat/env_opts.t t/compat/env.t t/compat/failure.t t/compat/inc-propagation.t t/compat/inc_taint.t t/compat/nonumbers.t t/compat/regression.t t/compat/subclass.t t/compat/switches.t t/compat/test-harness-compat.t t/compat/version.t t/console.t t/data/catme.1 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/if.pm t/lib/IO/c55Capture.pm t/lib/MyCustom.pm t/lib/MyFileSourceHandler.pm t/lib/MyGrammar.pm t/lib/MyIterator.pm t/lib/MyPerlSourceHandler.pm t/lib/MyResult.pm t/lib/MyResultFactory.pm t/lib/MySourceHandler.pm t/lib/NoFork.pm t/lib/NOP.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/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/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.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/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/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 META.json Test-Harness-3.30/Changes-2.64000444001750001750 6545112240531220 15075 0ustar00leonleon000000000000Revision history for Perl extension Test::Harness This is the revision history for the previous version of Test::Harness up to 2.64. The current version of test harness is a complete rewrite of this code. NEXT [FIXES] * prove's --perl=/path/to/file wasn't taking a value. * prove's version number was not getting incremented. From now on, prove's $VERSION will match Test::Harness's $VERSION, and I added a test to make sure this is the case. [ENHANCEMENTS] * Added test straps overload via HARNESS_STRAP_OVERLOAD environment variable. prove now takes a --strap=class parameter. Thanks, Adam Kennedy. 2.63_01 Fri Jun 30 16:59:50 CDT 2006 [ENHANCEMENTS] * Failed tests used to say "NOK x", and now say "NOK x/y". Thanks to Will Coleda. * Added the Test::Harness::Results object, so we have a well-defined object, and not just a hash that we pass around. Thanks to YAPC::NA 2006 Hackathon! 2.62 Thu Jun 8 14:11:57 CDT 2006 [FIXES] * Restored the behavior of dying if any subtests failed. This is a pretty crucial bug that I should have fixed long ago. Not having this means that CPANPLUS will install modules even if their tests fail. :-( 2.60 Wed May 24 14:48:44 CDT 2006 [FIXES] * Fixed the headers in the summary failure table. 2.58 Sat May 13 22:53:53 CDT 2006 No changes. Released to the world with a non-beta number. 2.57_06 Sun Apr 23 00:55:43 CDT 2006 [THINGS THAT MIGHT BREAK YOUR CODE] * Anything that displays a percentage of tests passed has been removed. Output at the end of failing runs is now different. [FIXES] * Fixed the TODO-passing patch from 2.57_05. [ENHANCEMENTS] * The unnecessary display of percentages of tests passing and failing have been removed. Tests are not a percentage game. * Caches the results of _default_inc(), which is expensive because of shelling out to get the pathnames. Benchmarking was showing that 15% of Test::Harness's time was spent in this function. For test suites with many test files, this can be significant. With this speedup, the "make test" for the Perl core speeds up 2.5%. Thanks to Nicholas Clark for finding this. [DOCUMENTATION] * Fixed HARNESS_PERL_SWITCHES typo. Thanks, Andreas Koenig. * Added docs on HARNESS_TIMER and --timer. Thanks, Mike O'Regan. 2.57_05 Wed Apr 19 00:31:10 CDT 2006 [ENHANCEMENTS] * Now shows details of the tests that unexpectedly pass, instead of just giving a number. Thanks, demerphq! [INTERNALS] * Fixed globbing to work under Perls before 5.6.0. Before Perl 5.6.0, prove just uses the internal glob() function. 2.57_04 Mon Apr 17 13:35:10 CDT 2006 [ENHANCEMENTS] * prove's globbing is now done with File::Glob::bsd_glob(). Otherwise, "prove c:\program files\svk\t\*" fails because glob() considers it to be two patterns, splitting on whitespace. Thanks to Audrey Tang. [DOCUMENTATION] * Added information about other TAP implementations in other languages. 2.57_03 Dec 31 2005 [THINGS THAT MAY BREAK YOUR CODE] * Internal functions _run_all_tests() and _show_results() no longer exist. You shouldn't have been using them anyway since they're prepended with underscores. [INTERNALS] * Added the ability to send test output to a filehandle of one's choosing. Two internal functions are now exposed: execute_tests() and get_results() (formerly _run_all_tests() and _show_results()). This should allow CPANPLUS to work properly with Module::Build. Thanks to Ken Williams. [DOCUMENTATION] * Hid the documentation for the private methods in Test::Harness::Straps. 2.57_02 Fri Dec 30 23:51:17 CST 2005 [THINGS THAT MAY BREAK YOUR CODE] * prove's --ext option has been removed. I'm betting that nobody used it. [ENHANCEMENTS] * prove can now take -w and -W switches, analogous to those in perl. This means that "prove -wlb t/*.t" is exactly the same as "make test". Thanks to Rob Kinyon. * Started a Test::Harness::Util module for code that may be reused by other Harness-using modules. [INTERNALS] * The t/prove*.t tests now use $^X to call prove. Thanks to Yves Orton. * Test::Harness::Straps no longer uses Win32::GetShortPathName(). Thanks to Gisle Aas. 2.57_01 Mon Dec 26 01:39:07 CST 2005 [FIXES] * Removed code and docs mentioning HARNESS_IGNORE_EXITCODE, which is not used anywhere. [ENHANCEMENTS] * If we have hi-res timings, then they're shown in integer milliseconds, rather than fractional seconds. * Added the --perl switch to prove. [DOCUMENTATION] * Added links to CPAN support sites. 2.56 Wed Sep 28 16:04:00 CDT 2005 [FIXES] * Incorporate bleadperl patch to fix Test::Harness on VMS. 2.54 Wed Sep 28 09:52:19 CDT 2005 [FIXES] * Test counts were wrong, so wouldn't install on Perls < 5.8.0. 2.53_02 Thu Aug 25 21:37:01 CDT 2005 [FIXES] * File order in prove is now sorted within the directory. It's not the sorting that's important as much as the deterministic results. Thanks to Adam Kennedy and Casey West for pointing this out, independently of each other, with 12 hours of the other. [INTERNALS] * Fix calls to podusage() to not use the DATA typeglob. Thanks sungo. 2.53_01 Sun Jul 10 10:45:27 CDT 2005 [FIXES] * If we go over 100,000 tests, it used to print out a warning for every test over 100,000. Now, we stop after the first. Thanks to Sebastien Aperghis-Tramoni. 2.52 Sun Jun 26 23:05:19 CDT 2005 No changes 2.51_02 [ENHANCEMENTS] * The Test::Harness timer is now off by default. Set HARNESS_TIMER true if you want it. Added --timer flag to prove. 2.50_01 [FIXES] * Call CORE::time() to figure out if we should print when we're printing once per second. Otherwise, we're using Time::HiRes' version of it. Thanks, Nicholas Clark. 2.50 Tue Jun 21 14:32:12 CDT 2005 [FIXES] * Added some includes in t/strap-analyze.t to make Cygwin happy. 2.49_02 Tue Jun 21 09:54:44 CDT 2005 [FIXES] * Added some includes in t/test_harness.t to make Cygwin happy. 2.49_01 Fri Jun 10 15:37:31 CDT 2005 [ENHANCEMENTS] * Now shows elapsed time in 1000ths of a second if Time::HiRes is available. [FIXES] * Test::Harness::Iterator didn't have a 1; at the end. Thanks to Steve Peters for finding it. 2.48 Fri Apr 22 22:41:46 CDT 2005 Released after weeks of non-complaint. 2.47_03 Wed Mar 2 16:52:55 CST 2005 [THINGS THAT MIGHT BREAK YOUR CODE] * Test::Harness now requires Perl 5.005_03 or above. [FIXES] * Fixed incorrect "confused by tests in wrong order" error in 2.47_02. 2.47_02 Tue Mar 1 23:15:47 CST 2005 [THINGS THAT MIGHT BREAK YOUR CODE] * Test directives for skip tests used to be anything that matches /^skip/i, like the word "skipped", but now it must match /^skip\s+/i. [ENHANCEMENTS] * T::H now sets environment variable HARNESS_VERSION, in case a test program wants to know what version of T::H it's running under. 2.47_01 Mon Feb 21 01:14:13 CST 2005 [FIXES] * Fixed a problem submitted by Craig Berry: Several of the Test::Harness tests now fail on VMS with the following warning: Can't find string terminator "]" anywhere before EOF at -e line 1. The problem is that when a command is piped to the shell and that command has a newline character embedded in it, the part after the newline is invisible to the shell. The patch below corrects that by escaping the newline so it is not subject to variable interpolation until it gets to the child's Perl one-liner. [ENHANCEMENTS] * Test::Harness::Straps now has diagnostic gathering without changing how tests are run. It also adds these messages by default. Note that the new method, _is_diagnostic(), is for internal use only. It may change soon. Thanks to chromatic. [DOCUMENTATION] * Expanded Test::Harness::TAP.pod, and added examples. * Fixed a crucial documentation typo in Test::Harness::Straps. 2.46 Thu Jan 20 11:50:59 CST 2005 Released. 2.45_02 Fri Dec 31 14:57:33 CST 2004 [ENHANCEMENTS] * Turns off buffering on both STDERR and STDOUT, so that the two output handles don't get out of sync with each other. Thanks to David Wheeler. * No longer requires, or supports, the HARNESS_OK_SLOW environment variable. Test counts are only updated once per second, which used to require having HARNESS_OK_SLOW set. 2.45_01 Fri Dec 17 22:39:17 CST 2004 [THINGS THAT MIGHT BREAK YOUR CODE] * Test::Harness now requires Perl 5.004_05. * We no longer try to print a stack if a coredump is detected. [FIXES] * Reverted Test::Harness::Iterator::next()'s use of readline, since it fails under Perl 5.5.4. * We no longer try to print a stack if a coredump is detected. This means that the external problems we've had with wait.ph now disappear. This resolves a number of problems that various Linux distros have, and closes a couple of RT tickets like #2729 and #7716. [ENHANCEMENTS] * Added Test::Harness->strap() method to access the internal strap. [DOCUMENTATION] * Obfuscated the rt.cpan.org email address. The damage is already done, but at least we'll have it hidden going forward. 2.44 Tue Nov 30 18:38:17 CST 2004 [INTERNALS] * De-anonymized the callbacks and handlers in Test::Harness, mostly so I can profile better. * Checks _is_header() only if _is_line() fails first. No point in checking every line of the input for something that can only occur once. * Inline the _detailize() function, which was getting called once per line of input. Reduced execution time about 5-7%. * Removed unnecessary temporary variables in Test::Harness::Straps and in Test::Harness::Iterator. 2.43_02 Thu Nov 25 00:20:36 CST 2004 [ENHANCEMENTS] * Added more debug output if $Test::Harness::Debug is on. [FIXES] * Test::Harness now removes default paths from the paths that it sets in PERL5LIB. This fixes RT #5649. Thanks, Schwern. [THINGS THAT MIGHT BREAK YOUR CODE] * Test::Harness::Straps' constructor no longer will work as an object method. You can't say $strap->new any more, but that's OK because you never really wanted to anyway. 2.43_01 [FIXES] * Added workaround for local $ENV{} bug on Cygwin to t/prove-switches.t. See the following RT tickets for details. https://rt.cpan.org/Ticket/Display.html?id=6452 http://rt.perl.org/rt3/Ticket/Display.html?id=30952 2.42 Wed Apr 28 22:13:11 CDT 2004 [ENHANCEMENTS] * prove -v now sets TEST_VERBOSE in case your tests rely on them. * prove globs the command line, since Win32's shell doesn't. [FIXES] * Cross-platform test fixes on t/prove-globbing.t 2.40 Tue Dec 30 20:38:59 CST 2003 [FIXES] * Test::Harness::Straps should now properly quote on VMS. [ENHANCEMENTS] * prove now takes a -l option to add lib/ to @INC. Now when you're building a module, you don't have to do a make before you run the prove. Thanks to David Wheeler for the idea. [INTERNALS] * Internal functions corestatus() and canonfailed() prepended with underscores, to indicate such. * Gratuitous text-only changes in Test::Harness::Iterator. * All tests now do their use_ok() in a BEGIN block. Some of the use_ok() calls were too much of a hassle to put into a BEGIN block, so I changed them to regular use calls. 2.38 Mon Nov 24 22:36:18 CST 2003 Released. See changes below. 2.37_03 Tue Nov 18 23:51:38 CST 2003 [ENHANCEMENTS] * prove -V now shows the Perl version being used. * Now there's a HARNESS_DEBUG flag that shows diagnostics as the harness runs the tests. This is different from HARNESS_VERBOSE, which shows test output, but not information about the harness itself. * Added _command_line() to the Strap API. [FIXES] * Bad interaction with Module::Build: The strap was only checking $ENV{HARNESS_PERL_SWITCHES} for definedness, but not emptiness. It now also strips any leading or trailing whitesapce from the switches. * Test::Harness and prove only quote those parms that actually need to be quoted: Have some whitespace and aren't already quoted. 2.36 Fri Nov 14 09:24:44 CST 2003 [FIXES] * t/prove-includes.t properly ignores PROVE_SWITCHES that you may already have set. 2.35_02 Thu Nov 13 09:57:36 CST 2003 [ENHANCEMENTS] * prove's --blib now works just like the blib pragma. 2.35_01 Wed Nov 12 23:08:45 CST 2003 [FIXES] * Fixed taint-handling and path preservation under MacOS. Thanks to Schwern for the patch and the tests. * Preserves case of -t or -T in the shebang line of the test. [ENHANCEMENTS] * Added -t to prove analogous to Perl's -t. Removed the --taint switch. * prove can take default options from the PROVE_SWITCHES variable. * Added HARNESS_PERL to allow you to specify the Perl interpreter to run the tests as. * prove's --perl switch sets the HARNESS_PERL on the fly for you. * Quotes the switches and filename in the subprogram. This helps with filenames with spaces that are subject to shell mangling. 2.34 Sat Nov 8 22:09:15 CST 2003 [FIXES] * Allowed prove to run on Perl versions < 5.6.0. [ENHANCEMENTS] * Command-line switches to prove may now be stacked. * Added check for proper Pod::Usage version. * "make clean" does a better job of cleaning up after itself. 2.32 Fri Nov 7 09:41:21 CST 2003 Test::Harness now includes a powerful development tool to help programmers work with automated tests. The prove utility runs test files against the harness, like a "make test", but with many advantages: * prove is designed as a development tool Perl users typically run the test harness through a makefile via "make test". That's fine for module distributions, but it's suboptimal for a test/code/debug development cycle. * prove is granular prove lets your run against only the files you want to check. Running "prove t/live/ t/master.t" checks every *.t in t/live, plus t/master.t. * prove has an easy verbose mode To get full test program output from "make test", you must set "HARNESS_VERBOSE" in the environment. prove has a "-v" option. * prove can run under taint mode prove's "-T" runs your tests under "perl -T". * prove can shuffle tests You can use prove's "--shuffle" option to try to excite problems that don't show up when tests are run in the same order every time. * Not everything is a module More and more users are using Perl's testing tools outside the context of a module distribution, and may not even use a makefile at all. Prove requires Pod::Usage, which is standard after Perl 5.004. I'm very excited about prove, and hope that developers will begin adopting it to their coding cycles. I welcome your comments at andy@petdance.com. There are also some minor bug fixes in Test::Harness itself, listed below in the 2.31_* notes. 2.31_05 Thu Nov 6 14:56:22 CST 2003 [FIXES] - If a MacPerl script had a shebang with -T, the -T wouldn't get passed as a switch. - Removed the -T on three *.t files, which didn't need them, and which were causing problems. - Conditionally installs bin/prove, depending on whether Pod::Usage is available, which prove needs. - Removed old leftover code from Makefile.PL. 2.31_04 Mon Nov 3 23:36:06 CST 2003 Minor tweaks here and there, almost ready to release. 2.31_03 Mon Nov 3 08:50:36 CST 2003 [FEATURES] - prove is almost feature-complete. Removed the handling of --exclude for excluding certain tests. It may go back in the future. - prove -d is now debug. Dry is prove -D. 2.31_02 Fri Oct 31 23:46:03 CST 2003 [FEATURES] - Added many more switches to prove: -d for dry run, and -b for blib. [FIXES] - T:H:Straps now recognizes MSWin32 in $^0. - RT#3811: Could do regex matching on garbage in _is_test(). Fixed by Yves Orton - RT#3827: Strips backslashes from and normalizes @INC entries for Win32. Fixed by Yves Orton. [INTERNALS] - Added $self->{_is_macos} to the T:H:Strap object. - t/test-harness.t sorts its test results, rather than relying on internal key order. 2.31_01 [FEATURES] - Added "prove" script to run a test or set of tests through the harness. Thanks to Curtis Poe for the foundation. [DOCUMENTATION] - Fixed POD problem in Test::Harness::Assert 2.30 Thu Aug 14 20:04:00 CDT 2003 No functional changes in this version. It's only to make some doc tweaks, and bump up the version number in T:H:Straps. [DOCUMENTATION] - Changed Schwern to Andy as the maintainer. - Incorporated the TODO file into Harness.pm proper. - Cleaned up formatting in Test::Harness::Straps. 2.29 Wed Jul 17 14:08:00 CDT 2003 - Released as 2.29. 2.28_91 Sun Jul 13 00:10:00 CDT 2003 [ENHANCEMENTS] - Added support for HARNESS_OK_SLOW. This will make a significant speedup for slower connections. - Folded in some changes from bleadperl that spiff up the failure reports. [INTERNALS] - Added some isa_ok() checks to the tests. - All Test::Harness* modules are used by use_ok() - Fixed the prototype for the canonfailed() function, not that it matters since it's never called without parens. 2.28_90 Sat Jul 05 20:21:00 CDT 2003 [ENHANCEMENTS] - Now, when you run a test harnessed, the numbers don't fly by one at a time, one update per second. This significantly speeds up the run time for running thousands of tests. *COUGH* Regexp::Common *COUGH* 2.28 Thu Apr 24 14:39:00 CDT 2003 - No functional changes. 2.27_05 Mon Apr 21 15:55:00 CDT 2003 - No functional changes. - Fixed circular depency in the test suite. Thanks, Rob Brown. 2.27_04 Sat Apr 12 21:42:00 CDT 2003 - Added test for $Test::Harness::Switches patch below. 2.27_03 Thu Apr 03 10:47:00 CDT 2003 - Fixed straps not respecting $Test::Harness::Switches. Thanks to Miyagawa for the patch. - Added t/pod.t to test POD validity. 2.27_02 Mon Mar 24 13:17:00 CDT 2003 2.27_01 Sun Mar 23 19:46:00 CDT 2003 - Handed over to Andy Lester for further maintenance. - Fixed when the path to perl contains spaces on Windows * Stas Bekman noticed that tests with no output at all were interpreted as passing - MacPerl test tweak for busted exit codes (bleadperl 17345) - Abigail and Nick Clark both hit the 100000 "huge test that will suck up all your memory" limit with legit tests. Made the check smarter to allow large, planned tests to work. - Partial fix of stats display when a test fails only because there's too many tests. - Made wait.ph and WCOREDUMP anti-vommit protection more robust in cases where wait.ph loads but WCOREDUMP() pukes when run. - Added a LICENSE. - Ilya noticed the per test skip reason was accumlating between tests. 2.26 Wed Jun 19 16:58:02 EDT 2002 - Workaround for MacPerl's lack of a working putenv. It will never see the PERL5LIB environment variable (perl@16942). 2.25 Sun Jun 16 03:00:33 EDT 2002 - $Strap is now a global to allow Test::Harness::Straps experimentation. - Little spelling nit in a diagnostic. - Chris Richmond noted that the runtests() docs were wrong. It will die, not return false, when any tests fail. This is silly, but historically necessary for 'make test'. Docs corrected. - MacPerl test fixes from Pudge. (mutation of bleadperl@16989) - Undef warning introduced in 2.24 on skipped tests with no reasons fixed. * Test::Harness now depends on File::Spec 2.24 Wed May 29 19:02:18 EDT 2002 * Nikola Knezevic found a bug when tests are completely skipped but no reason is given it was considered a failure. * Made Test::Harness::Straps->analyze_file & Test::Harness a bit more graceful when the test doesn't exist. 2.23 Wed May 22 12:59:47 EDT 2002 - reason for all skip wasn't being displayed. Broken in 2.20. - Changed the wait status tests to conform with POSIX standards. - Quieted some SYSTEM$ABORT noise leaking out from dying test tests on VMS. 2.22 Fri May 17 19:01:35 EDT 2002 - Fixed parsing of #!/usr/bin/perl-current to not see a -t. (RT #574) - Fixed exit codes on MPE/iX 2.21 Mon May 6 00:43:22 EDT 2002 - removed a bunch of dead code left over after 2.20's gutting. - The fix for the $^X "bug" added in 2.02 has been removed. It caused more trouble than the old bug (I'd never seen a problem before anyway) - 2.20 broke $verbose 2.20 Sat May 4 22:31:20 EDT 2002 * An almost complete conversion of the Test::Harness test parsing to use Test::Harness::Straps. 2.04 Tue Apr 30 00:54:49 EDT 2002 * Changing the output format of skips - Taking into account VMS's special exit codes in the tests. 2.03 Thu Apr 25 01:01:34 EDT 2002 * $^X fix made safer. - Noise from loading wait.ph to analyze core files supressed - MJD found a situation where a test could run Test::Harness out of memory. Protecting against that specific case. - Made the 1..M docs a bit clearer. - Fixed TODO tests so Test::Harness does not display a NOK for them. - Test::Harness::Straps->analyze_file() docs were not clear as to its effects 2.02 Thu Mar 14 18:06:04 EST 2002 * Ken Williams fixed the long standing $^X bug. * Added HARNESS_VERBOSE * Fixed a bug where Test::Harness::Straps was considering a test that is ok but died as passing. - Added the exit and wait codes of the test to the analyze_file() results. 2.01 Thu Dec 27 18:54:36 EST 2001 * Added 'passing' to the results to tell you if the test passed * Added Test::Harness::Straps example (examples/mini_harness.plx) * Header-at-end tests were being interpreted as failing sometimes - The 'skip_all' results from analyze* was not being set - analyze_fh() and analyze_file() now work more efficiently, reading line-by-line instead of slurping as before. 2.00 Sun Dec 23 19:13:57 EST 2001 - Fixed a warning on VMS. - Removed a little unnecessary code from analyze_file() - Made sure filehandles are getting closed - analyze() now considers "not \nok" to be a failure (VMSism) but Test::Harness still doesn't. 2.00_05 Mon Dec 17 22:08:02 EST 2001 * Wasn't filtering @INC properly when a test is run with -T, caused the command line to be too long on VMS. VMS should be 100% now. - Little bug in the skip 'various reasons' logic. - Minor POD nit in 5.004_04 - Little speling mistak 2.00_04 Sun Dec 16 00:33:32 EST 2001 * Major Test::Harness::Straps doc bug. 2.00_03 Sat Dec 15 23:52:17 EST 2001 * First release candidate * 'summary' is now 'details' * Test #1 is now element 0 on the details array. It works out better that way. * analyze_file() is more portable, but no longer taint clean * analyze_file() properly preserves @INC and handles -T switches - minor mistake in the test header line parsing 1.26 Mon Nov 12 15:44:01 EST 2001 * An excuse to upload a new version to CPAN to get Test::Harness back on the index. 2.00_00 Sat Sep 29 00:12:03 EDT 2001 * Partial gutting of the internals * Added Test::Harness::Straps 1.25 Tue Aug 7 08:51:09 EDT 2001 * Fixed a bug with tests failing if they're all skipped reported by Stas Bekman. - Fixed a very minor warning in 5.004_04 - Fixed displaying filenames not from @ARGV - Merging with bleadperl - minor fixes to the filename in the report - '[no reason given]' skip reason 1.24 Tue Aug 7 08:51:09 EDT 2001 - Added internal information about number of todo tests 1.23 Tue Jul 31 15:06:47 EDT 2001 - Merged in Ilya's "various reasons" patch * Fixed "not ok 23 - some name # TODO" style tests 1.22 Mon Jun 25 02:00:02 EDT 2001 * Fixed bug with failing tests using header at end. - Documented how Test::Harness deals with garbage input - Turned on test counter mismatch warning 1.21 Wed May 23 19:22:53 BST 2001 * No longer considered unstable. Merging back with the perl core. - Fixed minor nit about the report summary - Added docs on the meaning of the failure report - Minor POD nits fixed mirroring perl change 9176 - TODO and SEE ALSO expanded 1.20 Wed Mar 14 23:09:20 GMT 2001 by Michael G Schwern *UNSTABLE* * Fixed and tested with 5.004! - Added EXAMPLE docs - Added TODO docs - Now uneffected by -l, $\ or $, 1.19 Sat Mar 10 00:43:29 GMT 2001 by Michael G Schwern *UNSTABLE* - More internal reworking * Removed use of experimental /(?>...)/ feature for backwards compat * Removed use of open(my $fh, $file) for backwards compatibility * Removed use of Tie::StdHandle in tests for backwards compat * Added dire warning that this is unstable. - Added some tests from the old CPAN release 1.18 Mon Mar 5 17:35:11 GMT 2001 by Michael G Schwern * Under new management! * Test::Harness is now being concurrently shipped on CPAN as well as in the core. - Switched "our" for "use vars" and moved the minimum version back to 5.004. This may be optimistic. *** Missing version history to be extracted from Perl changes *** 1.07 Fri Feb 23 1996 by Andreas Koenig - Gisle sent me a documentation patch that showed me, that the unless(/^#/) is unnessessary. Applied the patch and deleted the block checking for "comment" lines. -- All lines are comment lines that do not match /^1\.\.([0-9]+)/ or /^(not\s+)?ok\b/. - Ilyaz request to print "ok (empty test case)" whenever we say 1..0 implemented. - Harness now doesn't abort anymore if we received confused test output, just warns instead. 1.05 Wed Jan 31 1996 by Andreas Koenig - More updates on docu and introduced the liberality that the script output may omit the test numbers. 1.03 Mon January 28 1996 by Andreas Koenig - Added the statistics for subtests. Updated the documentation. 1.02 by Andreas Koenig - This version reports a list of the tests that failed accompanied by some trivial statistics. The older (unnumbered) version stopped processing after the first failed test. - Additionally it reports the exit status if there is one. Test-Harness-3.30/NotBuild.PL000444001750001750 206612240531220 15141 0ustar00leonleon000000000000#!perl require 5.006; use strict; use warnings; use Module::Build; use File::Spec; use lib 'inc', File::Spec->canonpath('lib/'); # use our self to install use MyBuilder; my $builder = MyBuilder->new( module_name => 'Test::Harness', license => 'perl', installdirs => 'core', meta_merge => { resources => { homepage => 'http://testanything.org/', bugtracker => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness', MailingList => 'mailto:', repository => 'http://github.com/Perl-Toolchain-Gang/Test-Harness/tree/master', }, keywords => [ 'TAP', 'test harness', 'prove' ], }, recursive_test_files => 1, recommends => { 'Pod::Usage' => '1.12', # for 'prove' }, build_requires => {}, add_to_cleanup => ['Test-Harness-*'], script_files => ["bin/prove"], ( $Module::Build::VERSION >= 0.34 ) ? ( auto_configure_requires => 0 ) : (), ); $builder->create_build_script(); Test-Harness-3.30/README000444001750001750 103512240531220 14037 0ustar00leonleon000000000000Test-Harness 3.24 INSTALLATION To install Test::Harness using ExtUtils::MakeMaker do: perl Makefile.PL make make test make install To use Module::Build (preferred) do: perl NotBuild.PL ./Build ./Build test ./Build install This will install Test::Harness and the "prove" program. Type prove --help for more information. COPYRIGHT AND LICENCE Copyright (C) 2006, 2007 Curtis "Ovid" Poe This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Test-Harness-3.30/Makefile.PL000444001750001750 521112240531220 15131 0ustar00leonleon000000000000#!perl require 5.006; # This Makefile.PL is provided for installation compatibility. # Extra developer actions are in the Build.PL. use ExtUtils::MakeMaker qw/WriteMakefile prompt/; use strict; use warnings; my %mm_args = ( 'NAME' => 'Test::Harness', 'VERSION_FROM' => 'lib/Test/Harness.pm', 'INSTALLDIRS' => ($] < 5.011 ? 'perl' : 'site'), 'PL_FILES' => {}, 'test' => { 'TESTS' => 't/*.t t/compat/*.t' }, # The core autogenerates a Makefile.PL, and finds prove with utils/prove.PL 'EXE_FILES' => ['bin/prove'], 'PREREQ_PM' => { } ); { local $^W = 0; # Silence warning about non-numeric version if ( $ExtUtils::MakeMaker::VERSION >= '6.31' ) { $mm_args{LICENSE} = 'perl'; } } WriteMakefile(%mm_args); package MY; # Lifted from MM_Any.pm and modified so that make test tests against our # own code rather than the incumbent. If we don't do this we end up # loading a confused mixture of installed and new modules. sub test_via_harness { my ( $self, $perl, $tests ) = @_; return $self->SUPER::test_via_harness( qq{$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)"}, $tests ); } BEGIN { my %deny = ( manifest => 'dist_basics', dist => 'dist_core', ); while ( my ( $verb, $override ) = each %deny ) { my $super = "SUPER::$override"; no strict 'refs'; *{"MY::$override"} = sub { my ( $self, @args ) = @_; my $frag = $self->$super(@args); my $chunk = split_makefile_chunk($frag); replace_rule( $chunk, $verb, ":\n\t\$(NOECHO) \$(ECHO) " . "\"Please use 'Build.PL $verb' instead of 'Makefile.PL $verb'\"\n\n" ); return join_makefile_chunk($chunk); }; } } # Returns a reference to a hash containing # targets a reference to an array of makefile section names # sections a reference to a hash mapping makefile section names to the # text of those sections. sub split_makefile_chunk { my $chunk = shift; my $target = ' prefix'; my @targets = (); my %sections = (); for my $ln ( split /\n/, $chunk ) { if ( $ln =~ /^(\S+)/ ) { $target = $1; push @targets, $target; } $sections{$target} .= "$ln\n"; } return { targets => \@targets, sections => \%sections }; } sub join_makefile_chunk { my $chunk = shift; return join '', grep defined, map { $chunk->{sections}{$_} } @{ $chunk->{targets} }; } sub replace_rule { my ( $chunk, $name, $body ) = @_; $chunk->{sections}{$name} = "$name $body"; } Test-Harness-3.30/perlcriticrc000444001750001750 131212240531220 15565 0ustar00leonleon000000000000[-CodeLayout::ProhibitParensWithBuiltins] [CodeLayout::ProhibitHardTabs] allow_leading_tabs = 0 [-ControlStructures::ProhibitPostfixControls] [-Documentation::RequirePodAtEnd] [-Documentation::RequirePodSections] [-ErrorHandling::RequireCarping] [-InputOutput::ProhibitInteractiveTest] [-InputOutput::ProhibitBacktickOperators] [-Miscellanea::RequireRcsKeywords] [-Modules::RequireVersionVar] [-RegularExpressions::RequireExtendedFormatting] [-RegularExpressions::RequireLineBoundaryMatching] [-ValuesAndExpressions::ProhibitNoisyQuotes] [-ValuesAndExpressions::ProhibitEmptyQuotes] [Variables::ProhibitPackageVars] #add_packages = Test::Builder App::Ack File::Next [-Variables::ProhibitPunctuationVars] Test-Harness-3.30/t000755001750001750 012240531220 13266 5ustar00leonleon000000000000Test-Harness-3.30/t/parser-config.t000444001750001750 133312240531220 16347 0ustar00leonleon000000000000#!/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.30/t/callbacks.t000444001750001750 510412240531220 15527 0ustar00leonleon000000000000#!/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.30/t/state_results.t000444001750001750 1171112240531220 16532 0ustar00leonleon000000000000#!/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.30/t/harness-bailout.t000444001750001750 230412240531220 16707 0ustar00leonleon000000000000#!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.30/t/yamlish-output.t000444001750001750 470012240531220 16615 0ustar00leonleon000000000000#!/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.30/t/harness.t000444001750001750 7060412240531220 15302 0ustar00leonleon000000000000#!/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.30/t/yamlish.t000444001750001750 3601712240531220 15305 0ustar00leonleon000000000000#!perl -w use strict; use warnings; use lib 't/lib'; use Test::More; use TAP::Parser::YAMLish::Reader; my @SCHEDULE; BEGIN { @SCHEDULE = ( { name => '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 => [ 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.30/t/prove.t000444001750001750 13714512240531220 15016 0ustar00leonleon000000000000#!/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, }, 'TAP::Harness', 'one', 'two', 'three' ] ], }, # Test all options individually # { name => 'Just archive', # args => { # argv => [qw( one two three )], # archive => 1, # }, # expect => { # archive => 1, # }, # runlog => [ # [ { archive => 1, # }, # 'TAP::Harness', # '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 }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', 'one', 'two', 'three' ] ], }, { name => 'Just quiet', args => { argv => [qw( one two three )], quiet => 1, }, expect => { quiet => 1, }, runlog => [ [ '_runtests', { verbosity => -1, show_count => 1, }, 'TAP::Harness', '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, }, 'TAP::Harness', 'one', 'two', 'three' ] ], }, { name => 'Just recurse', args => { argv => [qw( one two three )], recurse => 1, }, expect => { recurse => 1, }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' ] ], }, { name => 'Just reverse', args => { argv => [qw( one two three )], backwards => 1, }, expect => { backwards => 1, }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'TAP::Harness', 'three', 'two', 'one' ] ], }, { name => 'Just shuffle', args => { argv => [qw( one two three )], shuffle => 1, }, expect => { shuffle => 1, }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', 'one', 'two', 'three' ] ], }, { name => 'Just verbose', args => { argv => [qw( one two three )], verbose => 1, }, expect => { verbose => 1, }, runlog => [ [ '_runtests', { verbosity => 1, show_count => 1, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', '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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', "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, }, 'TAP::Harness', "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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', 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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $dummy_test ] ], }, # Specify an oddball extension { name => 'Switch --ext=.wango', switches => ['--ext=.wango'], expect => { extensions => ['.wango'] }, runlog => [ [ '_runtests', { verbosity => 0, show_count => 1, }, 'TAP::Harness', ] ], }, # 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, }, 'TAP::Harness', ] ], }, # Source handlers { name => 'Switch --source simple', args => { argv => [qw( one two three )] }, switches => [ '--source', 'MyCustom', $dummy_test ], expect => { sources => { MyCustom => {}, }, }, runlog => [ [ '_runtests', { sources => { MyCustom => {}, }, verbosity => 0, show_count => 1, }, 'TAP::Harness', $dummy_test ] ], }, { name => 'Switch --sources with config', args => { argv => [qw( one two three )] }, skip => $Getopt::Long::VERSION >= 2.28 && $HAS_YAML ? 0 : 1, skip_reason => "YAML not available or Getopt::Long too old", switches => [ '--source', 'Perl', '--perl-option', 'foo=bar baz', '--perl-option', 'avg=0.278', '--source', 'MyCustom', '--source', 'File', '--file-option', 'extensions=.txt', '--file-option', 'extensions=.tmp', '--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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $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, }, 'TAP::Harness', $dummy_test ] ], }, # TODO # Hmm, that doesn't work... # { name => 'Switch -h', # args => { # argv => [qw( one two three )], # }, # switches => [ '-h', $dummy_test ], # expect => {}, # runlog => [ # [ '_runtests', # {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # { name => 'Switch --help', # args => { # argv => [qw( one two three )], # }, # switches => [ '--help', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # { name => 'Switch -?', # args => { # argv => [qw( one two three )], # }, # switches => [ '-?', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch -H', # args => { # argv => [qw( one two three )], # }, # switches => [ '-H', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch --man', # args => { # argv => [qw( one two three )], # }, # switches => [ '--man', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch -V', # args => { # argv => [qw( one two three )], # }, # switches => [ '-V', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch --version', # args => { # argv => [qw( one two three )], # }, # switches => [ '--version', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch --color!', # args => { # argv => [qw( one two three )], # }, # switches => [ '--color!', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $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 => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch --archive=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--archive=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch --formatter=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--formatter=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch -e', # args => { # argv => [qw( one two three )], # }, # switches => [ '-e', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $dummy_test # ] # ], # }, # # { name => 'Switch --harness=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--harness=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # 'TAP::Harness', # $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.30/t/process.t000444001750001750 176712240531220 15301 0ustar00leonleon000000000000#!/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.30/t/results.t000444001750001750 1727012240531220 15340 0ustar00leonleon000000000000#!/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.30/t/nested.t000444001750001750 153412240531220 15075 0ustar00leonleon000000000000#!/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.30/t/aggregator.t000444001750001750 2254612240531220 15763 0ustar00leonleon000000000000#!/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.30/t/nofork-mux.t000444001750001750 16712240531220 15701 0ustar00leonleon000000000000#!/usr/bin/perl -w BEGIN { use lib 't/lib'; } use strict; use warnings; use NoFork; require('t/multiplexer.t'); Test-Harness-3.30/t/source_handler.t000444001750001750 3050512240531220 16630 0ustar00leonleon000000000000#!/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.30/t/streams.t000555001750001750 1452612240531220 15321 0ustar00leonleon000000000000#!/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.30/t/iterator_factory.t000444001750001750 1146212240531220 17214 0ustar00leonleon000000000000#!/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.30/t/proveversion.t000444001750001750 137312240531220 16355 0ustar00leonleon000000000000#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } sub _has_TAP_Formatter_HTML { eval "use TAP::Formatter::HTML"; return $@ ? 0 : 1; } use strict; use warnings; use Test::More tests => 1; use IO::c55Capture; # for util SKIP: { skip "requires TAP::Formatter::HTML", 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.30/t/yamlish-writer.t000444001750001750 1625512240531220 16621 0ustar00leonleon000000000000#!/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.30/t/taint.t000444001750001750 246012240531220 14731 0ustar00leonleon000000000000#!/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.30/t/object.t000444001750001750 140412240531220 15055 0ustar00leonleon000000000000#!/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.30/t/perl5lib.t000444001750001750 220212240531220 15322 0ustar00leonleon000000000000#!/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.30/t/testargs.t000444001750001750 1171012240531220 15464 0ustar00leonleon000000000000#!/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.30/t/proverun.t000444001750001750 1021512240531220 15507 0ustar00leonleon000000000000#!/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.30/t/000-load.t000444001750001750 403312240531220 15024 0ustar00leonleon000000000000#!/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.30/t/multiplexer.t000444001750001750 1104112240531220 16177 0ustar00leonleon000000000000#!/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.30/t/parser-subclass.t000444001750001750 431712240531220 16726 0ustar00leonleon000000000000#!/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.30/t/scheduler.t000444001750001750 1252312240531220 15611 0ustar00leonleon000000000000#!/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.30/t/regression.t000444001750001750 33717212240531220 16045 0ustar00leonleon000000000000#!/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.30/t/harness-subclass.t000444001750001750 312112240531220 17065 0ustar00leonleon000000000000#!/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.30/t/file.t000444001750001750 3316012240531220 14552 0ustar00leonleon000000000000#!/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.30/t/parse.t000555001750001750 7574012240531220 14762 0ustar00leonleon000000000000#!/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.30/t/base.t000444001750001750 1126712240531220 14551 0ustar00leonleon000000000000#!/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.30/t/spool.t000444001750001750 617012240531220 14750 0ustar00leonleon000000000000#!/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.30/t/proveenv.t000444001750001750 52212240531220 15433 0ustar00leonleon000000000000#!perl use strict; use warnings; use lib 't/lib'; use Test::More tests => 2; use App::Prove; { local $ENV{HARNESS_TIMER} = 0; my $prv = App::Prove->new; ok !$prv->timer, 'timer set via HARNESS_TIMER'; } { local $ENV{HARNESS_TIMER} = 1; my $prv = App::Prove->new; ok $prv->timer, 'timer set via HARNESS_TIMER'; } Test-Harness-3.30/t/state.t000444001750001750 1731412240531220 14756 0ustar00leonleon000000000000#!/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.30/t/premature-bailout.t000444001750001750 451112240531220 17252 0ustar00leonleon000000000000#!/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.30/t/bailout.t000555001750001750 617712240531220 15265 0ustar00leonleon000000000000#!/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.30/t/grammar.t000444001750001750 2706712240531220 15272 0ustar00leonleon000000000000#!/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 { 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.30/t/nofork.t000555001750001750 306412240531220 15114 0ustar00leonleon000000000000#!/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.30/t/iterators.t000444001750001750 1326712240531220 15655 0ustar00leonleon000000000000#!/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.30/t/unicode.t000444001750001750 736012240531220 15244 0ustar00leonleon000000000000#!/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.30/t/glob-to-regexp.t000444001750001750 173412240531220 16450 0ustar00leonleon000000000000#!/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.30/t/source.t000555001750001750 2033012240531220 15131 0ustar00leonleon000000000000#!/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.30/t/proverc.t000444001750001750 73012240531220 15250 0ustar00leonleon000000000000#!/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.30/t/console.t000444001750001750 207312240531220 15254 0ustar00leonleon000000000000use 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.30/t/errors.t000444001750001750 1122312240531220 15143 0ustar00leonleon000000000000#!/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.30/t/proverc000755001750001750 012240531220 14746 5ustar00leonleon000000000000Test-Harness-3.30/t/proverc/emptyexec000444001750001750 1312240531220 16763 0ustar00leonleon000000000000--exec '' Test-Harness-3.30/t/source_tests000755001750001750 012240531220 16010 5ustar00leonleon000000000000Test-Harness-3.30/t/source_tests/harness000444001750001750 11312240531220 17506 0ustar00leonleon000000000000#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - this is a test END_TESTS Test-Harness-3.30/t/source_tests/source.pl000444001750001750 10612240531220 17757 0ustar00leonleon000000000000#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - source.pl END_TESTS Test-Harness-3.30/t/source_tests/source.bat000444001750001750 14712240531220 20117 0ustar00leonleon000000000000@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.30/t/source_tests/source_args.sh000555001750001750 6612240531220 20762 0ustar00leonleon000000000000#!/bin/sh echo "1..1" echo "ok 1 - source_args.sh $1" Test-Harness-3.30/t/source_tests/harness_badtap000444001750001750 16012240531220 21023 0ustar00leonleon000000000000#!/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.30/t/source_tests/source.tap000444001750001750 2712240531220 20112 0ustar00leonleon0000000000001..1 ok 1 - source.tap Test-Harness-3.30/t/source_tests/source.sh000555001750001750 5612240531220 17745 0ustar00leonleon000000000000#!/bin/sh echo "1..1" echo "ok 1 - source.sh" Test-Harness-3.30/t/source_tests/source.1000444001750001750 2512240531220 17464 0ustar00leonleon0000000000001..1 ok 1 - source.1 Test-Harness-3.30/t/source_tests/harness_failure000444001750001750 35312240531220 21223 0ustar00leonleon000000000000#!/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.30/t/source_tests/harness_complain000444001750001750 16512240531220 21377 0ustar00leonleon000000000000#!/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.30/t/source_tests/source000444001750001750 22512240531220 17347 0ustar00leonleon000000000000#!/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.30/t/source_tests/source.t000444001750001750 10512240531220 17606 0ustar00leonleon000000000000#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - source.t END_TESTS Test-Harness-3.30/t/source_tests/psql.bat000555001750001750 67312240531220 17605 0ustar00leonleon000000000000@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.30/t/source_tests/harness_directives000444001750001750 26312240531220 21735 0ustar00leonleon000000000000#!/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.30/t/sample-tests000755001750001750 012240531220 15707 5ustar00leonleon000000000000Test-Harness-3.30/t/sample-tests/skip_nomsg000444001750001750 4612240531220 20100 0ustar00leonleon000000000000print < 1; ok 23, 42; Test-Harness-3.30/t/sample-tests/out_err_mix000444001750001750 34712240531220 20307 0ustar00leonleon000000000000sub _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.30/t/sample-tests/head_fail000444001750001750 16512240531220 17645 0ustar00leonleon000000000000print < 1; ok( grep( /examples/, @INC ) ); Test-Harness-3.30/t/sample-tests/version_old000444001750001750 11412240531220 20266 0ustar00leonleon000000000000print <>= 1; print shift @parts; } sleep $delay if ( $delay_at & 1 ); Test-Harness-3.30/t/sample-tests/space_after_plan000444001750001750 16712240531220 21241 0ustar00leonleon000000000000# 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.30/t/sample-tests/taint_warn000444001750001750 34212240531220 20114 0ustar00leonleon000000000000#!/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.30/t/sample-tests/taint000444001750001750 21412240531220 17063 0ustar00leonleon000000000000#!/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.30/t/sample-tests/descriptive000444001750001750 25012240531220 20265 0ustar00leonleon000000000000print < \\ ok 2 Not a continuation line DUMMY_TEST Test-Harness-3.30/t/sample-tests/die_last_minute000444001750001750 15712240531220 21117 0ustar00leonleon000000000000print < Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338 Test-Harness-3.30/t/lib000755001750001750 012240531220 14034 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/EmptyParser.pm000444001750001750 62212240531220 16762 0ustar00leonleon000000000000package 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.30/t/lib/MyResult.pm000444001750001750 46012240531220 16273 0ustar00leonleon000000000000# 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.30/t/lib/MyIterator.pm000444001750001750 66212240531220 16612 0ustar00leonleon000000000000# 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.30/t/lib/MyGrammar.pm000444001750001750 46212240531220 16405 0ustar00leonleon000000000000# 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.30/t/lib/if.pm000444001750001750 227212240531220 15130 0ustar00leonleon000000000000package 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.30/t/lib/NoFork.pm000444001750001750 44212240531220 15705 0ustar00leonleon000000000000package 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.30/t/lib/MySourceHandler.pm000444001750001750 144612240531220 17600 0ustar00leonleon000000000000# 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.30/t/lib/MyResultFactory.pm000444001750001750 57212240531220 17627 0ustar00leonleon000000000000# 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.30/t/lib/MyFileSourceHandler.pm000444001750001750 127612240531220 20401 0ustar00leonleon000000000000# 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.30/t/lib/NOP.pm000444001750001750 10112240531220 15133 0ustar00leonleon000000000000package NOP; # Do nothing much sub new { bless {}, shift } 1; Test-Harness-3.30/t/lib/MyCustom.pm000444001750001750 30412240531220 16264 0ustar00leonleon000000000000# 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.30/t/lib/MyPerlSourceHandler.pm000444001750001750 67112240531220 20402 0ustar00leonleon000000000000# 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.30/t/lib/Test000755001750001750 012240531220 14753 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/Test/More.pm000444001750001750 11507312240531220 16417 0ustar00leonleon000000000000package Test::More; use 5.006; use strict; use warnings; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my ( $file, $line ) = ( caller(1) )[ 1, 2 ]; warn @_, " at $file line $line\n"; } our (@EXPORT, %EXPORT_TAGS, $TODO); our $VERSION = '0.72'; $VERSION = eval $VERSION; # make the alpha version come out as a number use base qw(Test::Builder::Module); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag BAIL_OUT ); =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => 23; # or use Test::More qw(no_plan); # or use Test::More skip_all => $reason; BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); # Various ways to say "ok" ok($got eq $expected, $test_name); is ($got, $expected, $test_name); isnt($got, $expected, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($got, qr/expected/, $test_name); unlike($got, qr/expected/, $test_name); cmp_ok($got, '==', $expected, $test_name); is_deeply($got_complex_structure, $expected_complex_structure, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); BAIL_OUT($why); # UNIMPLEMENTED!!! my @status = Test::More::status; =head1 DESCRIPTION B If you're just getting started writing tests, have a look at Test::Simple first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => 23; There are rare cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare that you have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); B: using no_plan requires a Test::Harness upgrade else it will think everything has failed. See L). In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the plan() function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my $tb = Test::More->builder; $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; while ( $idx <= $#{$list} ) { my $item = $list->[$idx]; if ( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } else { push @other, $item; } $idx++; } @$list = @other; } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($got eq $expected, $test_name); This simply evaluates any expression (C<$got eq $expected> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep !defined $_, @items, 'items populated' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 'sufficient mucus' # in foo.t at line 42. This is the same as Test::Simple's ok() routine. =cut sub ok ($;$) { my ( $test, $name ) = @_; my $tb = Test::More->builder; $tb->ok( $test, $name ); } =item B =item B is ( $got, $expected, $test_name ); isnt( $got, $expected, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. ok() cannot know what you are testing for (beyond the name), but is() and isnt() know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test 'Is foo the same as bar?' # in foo.t at line 139. # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use is() and isnt() over ok() where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); This does not check if C is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use ok(). ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); For those grammatical pedants out there, there's an C function which is an alias of isnt(). =cut sub is ($$;$) { my $tb = Test::More->builder; $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; $tb->isnt_eq(@_); } *isn't = \&isnt; =item B like( $got, qr/expected/, $test_name ); Similar to ok(), like() matches $got against the regex C. So this: like($got, qr/expected/, 'this is like that'); is similar to: ok( $got =~ /expected/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $got, '/expected/', 'this is like that' ); Regex options may be placed on the end (C<'/expected/i'>). Its advantages over ok() are similar to that of is() and isnt(). Better diagnostics on failure. =cut sub like ($$;$) { my $tb = Test::More->builder; $tb->like(@_); } =item B unlike( $got, qr/expected/, $test_name ); Works exactly as like(), only it checks if $got B match the given pattern. =cut sub unlike ($$;$) { my $tb = Test::More->builder; $tb->unlike(@_); } =item B cmp_ok( $got, $op, $expected, $test_name ); Halfway between ok() and is() lies cmp_ok(). This allows you to compare two arguments using any binary perl operator. # ok( $got eq $expected ); cmp_ok( $got, 'eq', $expected, 'this eq that' ); # ok( $got == $expected ); cmp_ok( $got, '==', $expected, 'this == that' ); # ok( $got && $expected ); cmp_ok( $got, '&&', $expected, 'this && that' ); ...etc... Its advantage over ok() is when the test fails you'll know what $got and $expected were: not ok 1 # Failed test in foo.t at line 12. # '23' # && # undef It's also useful in those cases where you are comparing numbers and is()'s use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); =cut sub cmp_ok($$$;$) { my $tb = Test::More->builder; $tb->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single can_ok() call counts as one test. If you desire otherwise, use: for my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my ( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless ($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless (@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); for my $method (@methods) { $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $tb->ok( !@nok, $name ); $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given C<< $object->isa($class) >>. Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my ( $object, $class, $obj_name ) = @_; my $tb = Test::More->builder; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if ( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif ( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides my ( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); if ($error) { if ( $error =~ /^Can't call method "isa" on unblessed reference/ ) { # Its an unblessed reference if ( !UNIVERSAL::isa( $object, $class ) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. Here's the error. $error WHOA } } elsif ( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if ($diag) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } else { $ok = $tb->ok( 1, $name ); } return $ok; } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok(). In this case, you can simply use pass() (to declare the test ok) or fail (for not ok). They are synonyms for ok(1) and ok(0). Use these very, very, very sparingly. =cut sub pass (;$) { my $tb = Test::More->builder; $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; $tb->ok( 0, @_ ); } =back =head2 Module tests You usually want to test if the module you're testing loads ok, rather than just vomiting if its load fails. For such purposes we have C and C. =over 4 =item B BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); Version numbers can be checked like so: # Just like "use Some::Module 1.02" BEGIN { use_ok('Some::Module', 1.02) } Don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } because the notion of "compile-time" is relative. Instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } =cut sub use_ok ($;@) { my ( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my ( $pack, $filename, $line ) = caller; local ( $@, $!, $SIG{__DIE__} ); # isolate eval if ( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. eval <ok( !$@, "use $module;" ); unless ($ok) { chomp $@; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(< require_ok($module); require_ok($file); Like use_ok(), except it requires the $module or $file. =cut sub require_ok ($) { my ($module) = shift; my $tb = Test::More->builder; my $pack = caller; # Try to deterine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); local ( $!, $@, $SIG{__DIE__} ); # isolate eval local $SIG{__DIE__}; eval <ok( !$@, "require $module;" ); unless ($ok) { chomp $@; $tb->diag(< I'm not quite sure what will happen with filehandles. =over 4 =item B is_deeply( $got, $expected, $test_name ); Similar to is(), except that if $got and $expected are references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. is_deeply() compares the dereferenced values of references, the references themselves (except for their type) are ignored. This means aspects such as blessing and ties are not considered "different". is_deeply() current has very limited handling of function reference and globs. It merely checks if they have the same referent. This may improve in the future. Test::Differences and Test::Deep provide more in-depth functionality along these lines. =cut our (@Data_Stack, %Refs_Seen); my $DNE = bless [], 'Does::Not::Exist'; sub _dne { ref $_[0] eq ref $DNE; } sub is_deeply { my $tb = Test::More->builder; unless ( @_ == 2 or @_ == 3 ) { my $msg = <ok(0); } my ( $got, $expected, $name ) = @_; $tb->_unoverload_str( \$expected, \$got ); my $ok; if ( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq( $got, $expected, $name ); } elsif ( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack( { vals => [ $got, $expected ] } ) ); } else { # both references local @Data_Stack = (); if ( _deep_check( $got, $expected ) ) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack(@Data_Stack) ); } } return $ok; } sub _format_stack { my (@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; for my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if ( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif ( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif ( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; for my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { return $type if UNIVERSAL::isa( $thing, $type ); } return ''; } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Like C @diagnostic_message is simply concatenated together. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test 'There's a foo user' # in foo.t at line 52. # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it it won't interfere with the test. =cut sub diag { my $tb = Test::More->builder; $tb->diag(@_); } =back =head2 Conditional tests Sometimes running a test under certain conditions will cause the test script to die. A certain function or method isn't implemented (such as fork() on MacOS), some resource isn't available (like a net connection) or a module isn't available. In these cases it's necessary to skip tests, or declare that they are supposed to fail but will work in the future (a todo test). For more details on the mechanics of skip and todo tests see L. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. If your plan is C $how_many is optional and will default to 1. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut #'# sub skip { my ( $why, $how_many ) = @_; my $tb = Test::More->builder; unless ( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } if ( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for ( 1 .. $how_many ) { $tb->skip($why); } no warnings 'exiting'; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". Test::Harness will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. B: TODO tests require a Test::Harness upgrade else it will treat it as a normal failure. See L). =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. Test::Harness will interpret them as passing. =cut sub todo_skip { my ( $why, $how_many ) = @_; my $tb = Test::More->builder; unless ( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for ( 1 .. $how_many ) { $tb->todo_skip($why); } no warnings 'exiting'; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like fork() or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Test control =over 4 =item B BAIL_OUT($reason); Indicates to the harness that things are going so badly all testing should terminate. This includes the running any additional test scripts. This is typically used when testing cannot continue such as a critical module failing to compile or a necessary external utility not being available such as a database connection failing. The test will exit with 255. =cut sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } =back =head2 Discouraged comparison functions The use of the following functions is discouraged as they are not actually testing functions and produce no diagnostics to help figure out what went wrong. They were written before is_deeply() existed because I couldn't figure out how to display a useful diff of two arbitrary data structures. These functions are usually used inside an ok(). ok( eq_array(\@got, \@expected) ); C can do that better and with diagnostics. is_deeply( \@got, \@expected ); They may be deprecated in future versions. =over 4 =item B my $is_eq = eq_array(\@got, \@expected); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { local @Data_Stack; _deep_check(@_); } sub _eq_array { my ( $a1, $a2 ) = @_; if ( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for ( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my ( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { # Quiet uninitialized value warnings when comparing undefs. no warnings 'uninitialized'; $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. my $same_ref = !( !ref $e1 xor !ref $e2 ); my $not_ref = ( !ref $e1 and !ref $e2 ); if ( defined $e1 xor defined $e2 ) { $ok = 0; } elsif ( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif ( $same_ref and ( $e1 eq $e2 ) ) { $ok = 1; } elsif ($not_ref) { push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; $ok = 0; } else { if ( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if ( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif ( $type eq 'ARRAY' ) { $ok = _eq_array( $e1, $e2 ); } elsif ( $type eq 'HASH' ) { $ok = _eq_hash( $e1, $e2 ); } elsif ( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif ( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif ($type) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } else { _whoa( 1, "No type in _deep_check" ); } } } return $ok; } sub _whoa { my ( $check, $desc ) = @_; if ($check) { die < my $is_eq = eq_hash(\%got, \%expected); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { local @Data_Stack; return _deep_check(@_); } sub _eq_hash { my ( $a1, $a2 ) = @_; if ( grep !_type($_) eq 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; for my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B my $is_eq = eq_set(\@got, \@expected); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. ok( eq_set(\@got, \@expected) ); Is better written: is_deeply( [sort @got], [sort @expected] ); B By historical accident, this is not a true set comparison. While the order of elements does not matter, duplicate elements do. B eq_set() does not know how to deal with references at the top level. The following is an example of a comparison which might not work: eq_set([\1, \2], [\2, \1]); Test::Deep contains much better set comparison functions. =cut sub eq_set { my ( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. no warnings 'uninitialized'; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of Test::Builder which provides a single, unified backend for any test library to use. This means two test libraries which both use Test::Builder B. If you simply want to do a little tweaking of how the tests behave, you can access the underlying Test::Builder object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the Test::Builder object underlying Test::More for you to play with. =back =head1 EXIT CODES If all your tests passed, Test::Builder will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Builder will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. B This behavior may go away in future versions. =head1 CAVEATS and NOTES =over 4 =item Backwards compatibility Test::More works with Perls as old as 5.004_05. =item Overloaded objects String overloaded objects are compared B (or in cmp_ok()'s case, strings or numbers as appropriate to the comparison op). This prevents Test::More from piercing an object's interface allowing better blackbox testing. So if a function starts returning overloaded objects instead of bare strings your tests won't notice the difference. This is good. However, it does mean that functions like is_deeply() cannot be used to test the internals of string overloaded objects. In this case I would suggest Test::Deep which contains more flexible testing functions for complex data structures. =item Threads Test::More will only be aware of threads if "use threads" has been done I Test::More is loaded. This is ok: use threads; use Test::More; This may cause problems: use Test::More use threads; 5.8.1 and above are supported. Anything below that has too many bugs. =item Test::Harness upgrade no_plan and todo depend on new Test::Harness features and fixes. If you're going to distribute tests that use no_plan or todo your end-users will have to upgrade Test::Harness to the latest one on CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness will work fine. Installing Test::More should also upgrade Test::Harness. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's Test module. I was largely unaware of its existence when I'd first written my own ok() routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L is the old testing module. Its main benefit is that it has been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. L for more ways to test complex data structures. And it plays well with Test::More. L is like XUnit but more perlish. L gives you more powerful complex data structure testing. L is XUnit style testing. L shows the idea of embedded testing. L installs a whole bunch of useful test modules. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa gang. =head1 BUGS See F to report and view bugs. =head1 COPYRIGHT Copyright 2001-2002, 2004-2006 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Test-Harness-3.30/t/lib/Test/Builder.pm000444001750001750 12226712240531220 17106 0ustar00leonleon000000000000package Test::Builder; use 5.006; # $^C was only introduced in 5.005-ish. We do this to prevent # use of uninitialized value warnings in older perls. $^C ||= 0; use strict; use warnings; our $VERSION = '0.72'; $VERSION = eval $VERSION; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; # Load threads::shared when threads are turned on. # 5.8.0's threads are so busted we no longer support them. if ( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { require threads::shared; # Hack around YET ANOTHER threads::shared bug. It would # occassionally forget the contents of the variable when sharing it. # So we first copy the data, then share, then put our copy back. *share = sub (\[$@%]) { my $type = ref $_[0]; my $data; if ( $type eq 'HASH' ) { %$data = %{ $_[0] }; } elsif ( $type eq 'ARRAY' ) { @$data = @{ $_[0] }; } elsif ( $type eq 'SCALAR' ) { $$data = ${ $_[0] }; } else { die( "Unknown type: " . $type ); } $_[0] = &threads::shared::share( $_[0] ); if ( $type eq 'HASH' ) { %{ $_[0] } = %$data; } elsif ( $type eq 'ARRAY' ) { @{ $_[0] } = @$data; } elsif ( $type eq 'SCALAR' ) { ${ $_[0] } = $$data; } else { die( "Unknown type: " . $type ); } return $_[0]; }; } # 5.8.0's threads::shared is busted when threads are off # and earlier Perls just don't have that module at all. else { *share = sub { return $_[0] }; *lock = sub {0}; } } =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use Test::Builder; use base qw(Exporter); @EXPORT = qw(ok); my $Test = Test::Builder->new; $Test->output('my_logfile'); sub import { my($self) = shift; my $pack = caller; $Test->exported_to($pack); $Test->plan(@_); $self->export_to_level(1, $self, 'ok'); } sub ok { my($test, $name) = @_; $Test->ok($test, $name); } =head1 DESCRIPTION Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program C always returns the same Test::Builder object. No matter how many times you call new(), you're getting the same object. This is called a singleton. This is done so that multiple modules share such global information as the test counter and where test output is going. If you want a completely new Test::Builder object different from the singleton, use C. =cut my $Test = Test::Builder->new; sub new { my ($class) = shift; $Test ||= $class->create; return $Test; } =item B my $Test = Test::Builder->create; Ok, so there can be more than one Test::Builder object and this is how you get it. You might use this instead of C if you're testing a Test::Builder based module, but otherwise you probably want C. B: the implementation is not complete. C, for example, is still shared amongst B Test::Builder objects, even ones created using this method. Also, the method name may change in the future. =cut sub create { my $class = shift; my $self = bless {}, $class; $self->reset; return $self; } =item B $Test->reset; Reinitializes the Test::Builder singleton to its original state. Mostly useful for tests run in persistent environments where the same test might be run multiple times in the same process. =cut our $Level; sub reset { my ($self) = @_; # We leave this a global because it has to be localized and localizing # hash keys is just asking for pain. Also, it was documented. $Level = 1; $self->{Test_Died} = 0; $self->{Have_Plan} = 0; $self->{No_Plan} = 0; $self->{Original_Pid} = $$; share( $self->{Curr_Test} ); $self->{Curr_Test} = 0; $self->{Test_Results} = &share( [] ); $self->{Exported_To} = undef; $self->{Expected_Tests} = 0; $self->{Skip_All} = 0; $self->{Use_Nums} = 1; $self->{No_Header} = 0; $self->{No_Ending} = 0; $self->_dup_stdhandles unless $^C; return undef; } =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This is important for getting TODO tests right. =cut sub exported_to { my ( $self, $pack ) = @_; if ( defined $pack ) { $self->{Exported_To} = $pack; } return $self->{Exported_To}; } =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call plan(), don't call any of the other methods below. =cut sub plan { my ( $self, $cmd, $arg ) = @_; return unless $cmd; local $Level = $Level + 1; if ( $self->{Have_Plan} ) { $self->croak("You tried to plan twice"); } if ( $cmd eq 'no_plan' ) { $self->no_plan; } elsif ( $cmd eq 'skip_all' ) { return $self->skip_all($arg); } elsif ( $cmd eq 'tests' ) { if ($arg) { local $Level = $Level + 1; return $self->expected_tests($arg); } elsif ( !defined $arg ) { $self->croak("Got an undefined number of tests"); } elsif ( !$arg ) { $self->croak("You said to run 0 tests"); } } else { my @args = grep {defined} ( $cmd, $arg ); $self->croak("plan() doesn't understand @args"); } return 1; } =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the # of tests we expect this test to run and prints out the appropriate headers. =cut sub expected_tests { my $self = shift; my ($max) = @_; if (@_) { $self->croak( "Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/ and $max > 0; $self->{Expected_Tests} = $max; $self->{Have_Plan} = 1; $self->_print("1..$max\n") unless $self->no_header; } return $self->{Expected_Tests}; } =item B $Test->no_plan; Declares that this test will run an indeterminate # of tests. =cut sub no_plan { my $self = shift; $self->{No_Plan} = 1; $self->{Have_Plan} = 1; } =item B $plan = $Test->has_plan Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =cut sub has_plan { my $self = shift; return ( $self->{Expected_Tests} ) if $self->{Expected_Tests}; return ('no_plan') if $self->{No_Plan}; return (undef); } =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given $reason. Exits immediately with 0. =cut sub skip_all { my ( $self, $reason ) = @_; my $out = "1..0"; $out .= " # Skip $reason" if $reason; $out .= "\n"; $self->{Skip_All} = 1; $self->_print($out) unless $self->no_header; exit(0); } =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. They all return true if the test passed, false if the test failed. $name is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if $test is true, fail if $test is false. Just like Test::Simple's ok(). =cut sub ok { my ( $self, $test, $name ) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; $self->_plan_check; lock $self->{Curr_Test}; $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. $self->_unoverload_str( \$name ); $self->diag(<caller; my $todo = $self->todo($pack); $self->_unoverload_str( \$todo ); my $out; my $result = &share( {} ); unless ($test) { $out .= "not "; @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } $out .= "ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; if ( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } if ($todo) { $out .= " # TODO $todo"; $result->{reason} = $todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; $out .= "\n"; $self->_print($out); unless ($test) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; if ( defined $name ) { $self->diag(qq[ $msg test '$name'\n]); $self->diag(qq[ at $file line $line.\n]); } else { $self->diag(qq[ $msg test at $file line $line.\n]); } } return $test ? 1 : 0; } sub _unoverload { my $self = shift; my $type = shift; $self->_try( sub { require overload } ) || return; for my $thing (@_) { if ( $self->_is_object($$thing) ) { if ( my $string_meth = overload::Method( $$thing, $type ) ) { $$thing = $$thing->$string_meth(); } } } } sub _is_object { my ( $self, $thing ) = @_; return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; } sub _unoverload_str { my $self = shift; $self->_unoverload( q[""], @_ ); } sub _unoverload_num { my $self = shift; $self->_unoverload( '0+', @_ ); for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } } # This is a hack to detect a dualvar such as $! sub _is_dualvar { my ( $self, $val ) = @_; local $^W = 0; my $numval = $val + 0; return 1 if $numval != 0 and $numval ne $val; } =item B $Test->is_eq($got, $expected, $name); Like Test::More's is(). Checks if $got eq $expected. This is the string version. =item B $Test->is_num($got, $expected, $name); Like Test::More's is(). Checks if $got == $expected. This is the numeric version. =cut sub is_eq { my ( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; $self->_unoverload_str( \$got, \$expect ); if ( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; return $test; } return $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { my ( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; $self->_unoverload_num( \$got, \$expect ); if ( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; return $test; } return $self->cmp_ok( $got, '==', $expect, $name ); } sub _is_diag { my ( $self, $got, $type, $expect ) = @_; for my $val ( \$got, \$expect ) { if ( defined $$val ) { if ( $type eq 'eq' ) { # quote and force string context $$val = "'$$val'"; } else { # force numeric context $self->_unoverload_num($val); } } else { $$val = 'undef'; } } return $self->diag( sprintf < $Test->isnt_eq($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the string version. =item B $Test->isnt_num($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the numeric version. =cut sub isnt_eq { my ( $self, $got, $dont_expect, $name ) = @_; local $Level = $Level + 1; if ( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_cmp_diag( $got, 'ne', $dont_expect ) unless $test; return $test; } return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { my ( $self, $got, $dont_expect, $name ) = @_; local $Level = $Level + 1; if ( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_cmp_diag( $got, '!=', $dont_expect ) unless $test; return $test; } return $self->cmp_ok( $got, '!=', $dont_expect, $name ); } =item B $Test->like($this, qr/$regex/, $name); $Test->like($this, '/$regex/', $name); Like Test::More's like(). Checks if $this matches the given $regex. You'll want to avoid qr// if you want your tests to work before 5.005. =item B $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); Like Test::More's unlike(). Checks if $this B the given $regex. =cut sub like { my ( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; $self->_regex_ok( $this, $regex, '=~', $name ); } sub unlike { my ( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; $self->_regex_ok( $this, $regex, '!~', $name ); } =item B $Test->cmp_ok($this, $type, $that, $name); Works just like Test::More's cmp_ok(). $Test->cmp_ok($big_num, '!=', $other_big_num); =cut my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); sub cmp_ok { my ( $self, $got, $type, $expect, $name ) = @_; # Treat overloaded objects as numbers if we're asked to do a # numeric comparison. my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' : '_unoverload_str'; $self->$unoverload( \$got, \$expect ); my $test; { local ( $@, $!, $SIG{__DIE__} ); # isolate eval my $code = $self->_caller_context; # Yes, it has to look like this or 5.4.5 won't see the #line directive. # Don't ask me, man, I just work here. $test = eval " $code" . "\$got $type \$expect;"; } local $Level = $Level + 1; my $ok = $self->ok( $test, $name ); unless ($ok) { if ( $type =~ /^(eq|==)$/ ) { $self->_is_diag( $got, $type, $expect ); } else { $self->_cmp_diag( $got, $type, $expect ); } } return $ok; } sub _cmp_diag { my ( $self, $got, $type, $expect ) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; return $self->diag( sprintf <caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; return $code; } =back =head2 Other Testing Methods These are methods which are used in the course of writing a test but are not themselves tests. =over 4 =item B $Test->BAIL_OUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =cut sub BAIL_OUT { my ( $self, $reason ) = @_; $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); exit 255; } =for deprecated BAIL_OUT() used to be BAILOUT() =cut *BAILOUT = \&BAIL_OUT; =item B $Test->skip; $Test->skip($why); Skips the current test, reporting $why. =cut sub skip { my ( $self, $why ) = @_; $why ||= ''; $self->_unoverload_str( \$why ); $self->_plan_check; lock( $self->{Curr_Test} ); $self->{Curr_Test}++; $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( { 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, } ); my $out = "ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # skip"; $out .= " $why" if length $why; $out .= "\n"; $self->_print($out); return 1; } =item B $Test->todo_skip; $Test->todo_skip($why); Like skip(), only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =cut sub todo_skip { my ( $self, $why ) = @_; $why ||= ''; $self->_plan_check; lock( $self->{Curr_Test} ); $self->{Curr_Test}++; $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, } ); my $out = "not ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $self->_print($out); return 1; } =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like skip(), only it skips all the rest of the tests you plan to run and terminates the test. If you're running under no_plan, it skips once and terminates the test. =end _unimplemented =back =head2 Test building utility methods These methods are useful when writing your own test methods. =over 4 =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); Convenience method for building testing functions that take regular expressions as arguments, but need to work before perl 5.005. Takes a quoted regular expression produced by qr//, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or undef if it's argument is not recognised. For example, a version of like(), sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $this, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($this =~ m/$usable_regex/, $name); } =cut sub maybe_regex { my ( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; my ( $re, $opts ); # Check for qr/foo/ if ( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check for '/foo/' or 'm,foo,' elsif (( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; } return $usable_regex; } sub _regex_ok { my ( $self, $this, $regex, $cmp, $name ) = @_; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless ( defined $usable_regex ) { $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { my $test; my $code = $self->_caller_context; local ( $@, $!, $SIG{__DIE__} ); # isolate eval # Yes, it has to look like this or 5.4.5 won't see the #line directive. # Don't ask me, man, I just work here. $test = eval " $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; $test = !$test if $cmp eq '!~'; local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } unless ($ok) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; $self->diag( sprintf < my $return_from_code = $Test->try(sub { code }); my($return_from_code, $error) = $Test->try(sub { code }); Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls. $error is what would normally be in $@. It is suggested you use this in place of eval BLOCK. =cut sub _try { my ( $self, $code ) = @_; local $!; # eval can mess up $! local $@; # don't set $@ in the test local $SIG{__DIE__}; # don't trip an outside DIE handler. my $return = eval { $code->() }; return wantarray ? ( $return, $@ ) : $return; } =end private =item B my $is_fh = $Test->is_fh($thing); Determines if the given $thing can be used as a filehandle. =cut sub is_fh { my $self = shift; my $maybe_fh = shift; return 0 unless defined $maybe_fh; return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob return eval { $maybe_fh->isa("IO::Handle") } || # 5.5.4's tied() and can() doesn't like getting undef eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') }; } =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should $Test look when reporting where the test failed. Defaults to 1. Setting L<$Test::Builder::Level> overrides. This is typically useful localized: sub my_ok { my $test = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; $TB->ok($test); } To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. =cut sub level { my ( $self, $level ) = @_; if ( defined $level ) { $Level = $level; } return $Level; } =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Defaults to on. =cut sub use_numbers { my ( $self, $use_nums ) = @_; if ( defined $use_nums ) { $self->{Use_Nums} = $use_nums; } return $self->{Use_Nums}; } =item B $Test->no_diag($no_diag); If set true no diagnostics will be printed. This includes calls to diag(). =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described below. If this is true, none of that will be done. =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =cut for my $attribute (qw(No_Header No_Ending No_Diag)) { my $method = lc $attribute; my $code = sub { my ( $self, $no ) = @_; if ( defined $no ) { $self->{$attribute} = $no; } return $self->{$attribute}; }; no strict 'refs'; *{ __PACKAGE__ . '::' . $method } = $code; } =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given @msgs. Like C, arguments are simply appended together. Normally, it uses the failure_output() handle, but if this is for a TODO test, the todo_output() handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because diag() is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =cut sub diag { my ( $self, @msgs ) = @_; return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Smash args together like print does. # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; # Escape each line with a #. $msg =~ s/^/# /gm; # Stick a newline on the end if it needs it. $msg .= "\n" unless $msg =~ /\n\Z/; local $Level = $Level + 1; $self->_print_diag($msg); return 0; } =begin _private =item B<_print> $Test->_print(@msgs); Prints to the output() filehandle. =end _private =cut sub _print { my ( $self, @msgs ) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; my $msg = join '', @msgs; local ( $\, $", $, ) = ( undef, ' ', '' ); my $fh = $self->output; # Escape each line after the first with a # so we don't # confuse Test::Harness. $msg =~ s/\n(.)/\n# $1/sg; # Stick a newline on the end if it needs it. $msg .= "\n" unless $msg =~ /\n\Z/; print $fh $msg; } =begin private =item B<_print_diag> $Test->_print_diag(@msg); Like _print, but prints to the current diagnostic filehandle. =end private =cut sub _print_diag { my $self = shift; local ( $\, $", $, ) = ( undef, ' ', '' ); my $fh = $self->todo ? $self->todo_output : $self->failure_output; print $fh @_; } =item B $Test->output($fh); $Test->output($file); Where normal "ok/not ok" test output should go. Defaults to STDOUT. =item B $Test->failure_output($fh); $Test->failure_output($file); Where diagnostic output on test failures and diag() should go. Defaults to STDERR. =item B $Test->todo_output($fh); $Test->todo_output($file); Where diagnostics about todo test failures and diag() should go. Defaults to STDOUT. =cut sub output { my ( $self, $fh ) = @_; if ( defined $fh ) { $self->{Out_FH} = $self->_new_fh($fh); } return $self->{Out_FH}; } sub failure_output { my ( $self, $fh ) = @_; if ( defined $fh ) { $self->{Fail_FH} = $self->_new_fh($fh); } return $self->{Fail_FH}; } sub todo_output { my ( $self, $fh ) = @_; if ( defined $fh ) { $self->{Todo_FH} = $self->_new_fh($fh); } return $self->{Todo_FH}; } sub _new_fh { my $self = shift; my ($file_or_fh) = shift; my $fh; if ( $self->is_fh($file_or_fh) ) { $fh = $file_or_fh; } else { $fh = do { local *FH }; open $fh, ">$file_or_fh" or $self->croak("Can't open test output log $file_or_fh: $!"); _autoflush($fh); } return $fh; } sub _autoflush { my ($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; } sub _dup_stdhandles { my $self = shift; $self->_open_testhandles; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush( \*TESTOUT ); _autoflush( \*STDOUT ); _autoflush( \*TESTERR ); _autoflush( \*STDERR ); $self->output( \*TESTOUT ); $self->failure_output( \*TESTERR ); $self->todo_output( \*TESTOUT ); } my $Opened_Testhandles = 0; sub _open_testhandles { return if $Opened_Testhandles; # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open( TESTOUT, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; open( TESTERR, ">&STDERR" ) or die "Can't dup STDERR: $!"; $Opened_Testhandles = 1; } =item carp $tb->carp(@message); Warns with C<@message> but the message will appear to come from the point where the original test function was called (C<$tb->caller>). =item croak $tb->croak(@message); Dies with C<@message> but the message will appear to come from the point where the original test function was called (C<$tb->caller>). =cut sub _message_at_caller { my $self = shift; local $Level = $Level + 1; my ( $pack, $file, $line ) = $self->caller; return join( "", @_ ) . " at $file line $line.\n"; } sub carp { my $self = shift; warn $self->_message_at_caller(@_); } sub croak { my $self = shift; die $self->_message_at_caller(@_); } sub _plan_check { my $self = shift; unless ( $self->{Have_Plan} ) { local $Level = $Level + 2; $self->croak("You tried to run a test without a plan"); } } =back =head2 Test Status and Info =over 4 =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test number we're on. You usually shouldn't have to set this. If set forward, the details of the missing tests are filled in as 'unknown'. if set backward, the details of the intervening tests are deleted. You can erase history if you really want to. =cut sub current_test { my ( $self, $num ) = @_; lock( $self->{Curr_Test} ); if ( defined $num ) { unless ( $self->{Have_Plan} ) { $self->croak( "Can't change the current test number without a plan!"); } $self->{Curr_Test} = $num; # If the test counter is being pushed forward fill in the details. my $test_results = $self->{Test_Results}; if ( $num > @$test_results ) { my $start = @$test_results ? @$test_results : 0; for ( $start .. $num - 1 ) { $test_results->[$_] = &share( { 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef } ); } } # If backward, wipe history. Its their funeral. elsif ( $num < @$test_results ) { $#{$test_results} = $num - 1; } } return $self->{Curr_Test}; } =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =cut sub summary { my ($self) = shift; return map { $_->{'ok'} } @{ $self->{Test_Results} }; } =item B
my @tests = $Test->details; Like summary(), but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when current_test() is changed. In these cases, Test::Builder doesn't know the result of the test, so it's type is 'unkown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left undef. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since it's todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =cut sub details { my $self = shift; return @{ $self->{Test_Results} }; } =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); todo() looks for a $TODO variable in your tests. If set, all tests will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. todo() is about finding the right package to look for $TODO in. It uses the exported_to() package to find it. If that's not set, it's pretty good at guessing the right package to look at based on $Level. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly what $pack to use. =cut sub todo { my ( $self, $pack ) = @_; $pack = $pack || $self->exported_to || $self->caller($Level); return 0 unless $pack; no strict 'refs'; return defined ${ $pack . '::TODO' } ? ${ $pack . '::TODO' } : 0; } =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal caller(), except it reports according to your level(). =cut sub caller { my ( $self, $height ) = @_; $height ||= 0; my @caller = CORE::caller( $self->level + $height + 1 ); return wantarray ? @caller : $caller[0]; } =back =cut =begin _private =over 4 =item B<_sanity_check> $self->_sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly error message. =cut #'# sub _sanity_check { my $self = shift; $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); $self->_whoa( !$self->{Have_Plan} and $self->{Curr_Test}, 'Somehow your tests ran without a plan!' ); $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, 'Somehow you got a different number of results than tests ran!' ); } =item B<_whoa> $self->_whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and a note to contact the author. =cut sub _whoa { my ( $self, $check, $desc ) = @_; if ($check) { local $Level = $Level + 1; $self->croak(<<"WHOA"); WHOA! $desc This should never happen! Please contact the author immediately! WHOA } } =item B<_my_exit> _my_exit($exit_num); Perl seems to have some trouble with exiting inside an END block. 5.005_03 and 5.6.1 both seem to do odd things. Instead, this function edits $? directly. It should ONLY be called from inside an END block. It doesn't actually exit, that's your job. =cut sub _my_exit { $? = $_[0]; return 1; } =back =end _private =cut $SIG{__DIE__} = sub { # We don't want to muck with death in an eval, but $^S isn't # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing # with it. Instead, we use caller. This also means it runs under # 5.004! my $in_eval = 0; for ( my $stack = 1; my $sub = ( CORE::caller($stack) )[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } $Test->{Test_Died} = 1 unless $in_eval; }; sub _ending { my $self = shift; $self->_sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. # Exit if plan() was never called. This is so "require Test::Simple" # doesn't puke. # Don't do an ending if we bailed out. if ( ( $self->{Original_Pid} != $$ ) or ( !$self->{Have_Plan} && !$self->{Test_Died} ) or $self->{Bailed_Out} ) { _my_exit($?); return; } # Figure out if we passed or failed and print helpful messages. my $test_results = $self->{Test_Results}; if (@$test_results) { # The plan? We have no plan. if ( $self->{No_Plan} ) { $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; $self->{Expected_Tests} = $self->{Curr_Test}; } # Auto-extended arrays and elements which aren't explicitly # filled in with a shared reference will puke under 5.8.0 # ithreads. So we have to fill them in by hand. :( my $empty_result = &share( {} ); for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { $test_results->[$idx] = $empty_result unless defined $test_results->[$idx]; } my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; if ( $num_extra < 0 ) { my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. FAIL } elsif ( $num_extra > 0 ) { my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. FAIL } if ($num_failed) { my $num_tests = $self->{Curr_Test}; my $s = $num_failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $self->diag(<<"FAIL"); Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } if ( $self->{Test_Died} ) { $self->diag(<<"FAIL"); Looks like your test died just after $self->{Curr_Test}. FAIL _my_exit(255) && return; } my $exit_code; if ($num_failed) { $exit_code = $num_failed <= 254 ? $num_failed : 254; } elsif ( $num_extra != 0 ) { $exit_code = 255; } else { $exit_code = 0; } _my_exit($exit_code) && return; } elsif ( $self->{Skip_All} ) { _my_exit(0) && return; } elsif ( $self->{Test_Died} ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL _my_exit(255) && return; } else { $self->diag("No tests run!\n"); _my_exit(255) && return; } } END { $Test->_ending if defined $Test and !$Test->no_ending; } =head1 EXIT CODES If all your tests passed, Test::Builder will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Builder will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. =head1 THREADS In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is shared amongst all threads. This means if one thread sets the test number using current_test() they will all be effected. While versions earlier than 5.8.1 had threads they contain too many bugs to support. Test::Builder is only thread-aware if threads.pm is loaded I Test::Builder. =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, Test::Exception and Test::Differences all use Test::Builder. =head1 SEE ALSO Test::Simple, Test::More, Test::Harness =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 COPYRIGHT Copyright 2002, 2004 by chromatic Echromatic@wgz.orgE and Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Test-Harness-3.30/t/lib/Test/Simple.pm000444001750001750 1463312240531220 16726 0ustar00leonleon000000000000package Test::Simple; use 5.006; use strict; use warnings; our @EXPORT; our $VERSION = '0.72'; $VERSION = eval $VERSION; # make the alpha version come out as a number use base qw(Test::Builder::Module); @EXPORT = qw(ok); my $CLASS = __PACKAGE__; =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first! ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); ok() is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { $CLASS->builder->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets Test::Harness know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test 'Rating() get' # in t/film.t at line 14. ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.004. Test::Simple is thread-safe in perl 5.8.0 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More (i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L The original Perl testing module. =item L Elaborate unit testing. =item L, L Embed tests in your code! =item L Interprets the output of your test program. =back =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 COPYRIGHT Copyright 2001, 2002, 2004 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Test-Harness-3.30/t/lib/Test/Builder000755001750001750 012240531220 16341 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/Test/Builder/Module.pm000444001750001750 742312240531220 20267 0ustar00leonleon000000000000package Test::Builder::Module; use Test::Builder; use base qw(Exporter); $VERSION = '0.72'; use strict; use warnings; # 5.004's Exporter doesn't have export_to_level. my $_export_to_level = sub { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export( $callpkg, @_ ); }; =head1 NAME Test::Builder::Module - Base class for test modules =head1 SYNOPSIS # Emulates Test::Simple package Your::Module; my $CLASS = __PACKAGE__; use base 'Test::Builder::Module'; @EXPORT = qw(ok); sub ok ($;$) { my $tb = $CLASS->builder; return $tb->ok(@_); } 1; =head1 DESCRIPTION This is a superclass for Test::Builder-based modules. It provides a handful of common functionality and a method of getting at the underlying Test::Builder object. =head2 Importing Test::Builder::Module is a subclass of Exporter which means your module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... all act normally. A few methods are provided to do the C 23> part for you. =head3 import Test::Builder::Module provides an import() method which acts in the same basic way as Test::More's, setting the plan and controling exporting of functions and variables. This allows your module to set the plan independent of Test::More. All arguments passed to import() are passed onto C<< Your::Module->builder->plan() >> with the exception of C[qw(things to import)]>. use Your::Module import => [qw(this that)], tests => 23; says to import the functions this() and that() as well as set the plan to be 23 tests. import() also sets the exported_to() attribute of your builder to be the caller of the import() function. Additional behaviors can be added to your import() method by overriding import_extra(). =cut sub import { my ($class) = shift; my $test = $class->builder; my $caller = caller; $test->exported_to($caller); $class->import_extra( \@_ ); my (@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); $class->$_export_to_level( 1, $class, @imports ); } sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); my $idx = 0; while ( $idx <= $#{$list} ) { my $item = $list->[$idx]; if ( defined $item and $item eq 'import' ) { push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { push @other, $item; } $idx++; } @$list = @other; return @imports; } =head3 import_extra Your::Module->import_extra(\@import_args); import_extra() is called by import(). It provides an opportunity for you to add behaviors to your module based on its import list. Any extra arguments which shouldn't be passed on to plan() should be stripped off by this method. See Test::More for an example of its use. B This mechanism is I as it feels like a bit of an ugly hack in its current form. =cut sub import_extra { } =head2 Builder Test::Builder::Module provides some methods of getting at the underlying Test::Builder object. =head3 builder my $builder = Your::Class->builder; This method returns the Test::Builder object associated with Your::Class. It is not a constructor so you can call it as often as you like. This is the preferred way to get the Test::Builder object. You should I get it via C<< Test::Builder->new >> as was previously recommended. The object returned by builder() may change at runtime so you should call builder() inside each function rather than store it in a global. sub ok { my $builder = Your::Class->builder; return $builder->ok(@_); } =cut sub builder { return Test::Builder->new; } 1; Test-Harness-3.30/t/lib/App000755001750001750 012240531220 14554 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/App/Prove000755001750001750 012240531220 15647 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/App/Prove/Plugin000755001750001750 012240531220 17105 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/App/Prove/Plugin/Dummy2.pm000444001750001750 24412240531220 20735 0ustar00leonleon000000000000package 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.30/t/lib/App/Prove/Plugin/Dummy.pm000444001750001750 16112240531220 20651 0ustar00leonleon000000000000package App::Prove::Plugin::Dummy; use strict; use warnings; sub import { main::test_log_import(@_); } 1; Test-Harness-3.30/t/lib/Dev000755001750001750 012240531220 14552 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/Dev/Null.pm000444001750001750 51012240531220 16133 0ustar00leonleon000000000000# 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.30/t/lib/TAP000755001750001750 012240531220 14460 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/TAP/Parser000755001750001750 012240531220 15714 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/TAP/Parser/SubclassTest.pm000444001750001750 203512240531220 21026 0ustar00leonleon000000000000# 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.30/t/lib/TAP/Harness000755001750001750 012240531220 16063 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/TAP/Harness/TestSubclass.pm000444001750001750 31212240531220 21151 0ustar00leonleon000000000000package 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.30/t/lib/IO000755001750001750 012240531220 14343 5ustar00leonleon000000000000Test-Harness-3.30/t/lib/IO/c55Capture.pm000444001750001750 441212240531220 16757 0ustar00leonleon000000000000package 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.30/t/subclass_tests000755001750001750 012240531220 16327 5ustar00leonleon000000000000Test-Harness-3.30/t/subclass_tests/perl_source000444001750001750 11312240531220 20704 0ustar00leonleon000000000000#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - this is a test END_TESTS Test-Harness-3.30/t/subclass_tests/non_perl_source000444001750001750 6312240531220 21542 0ustar00leonleon000000000000#!/bin/sh echo "1..1" echo "ok 1 - this is a test" Test-Harness-3.30/t/compat000755001750001750 012240531220 14551 5ustar00leonleon000000000000Test-Harness-3.30/t/compat/failure.t000444001750001750 241512240531220 16524 0ustar00leonleon000000000000#!/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.30/t/compat/version.t000444001750001750 43012240531220 16535 0ustar00leonleon000000000000#!/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.30/t/compat/inc_taint.t000444001750001750 116212240531220 17043 0ustar00leonleon000000000000#!/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.30/t/compat/test-harness-compat.t000444001750001750 6465312240531220 21032 0ustar00leonleon000000000000#!/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.30/t/compat/nonumbers.t000444001750001750 23012240531220 17056 0ustar00leonleon000000000000if ( $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.30/t/compat/env_opts.t000444001750001750 277212240531220 16740 0ustar00leonleon000000000000#!/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.30/t/compat/inc-propagation.t000444001750001750 260712240531220 20172 0ustar00leonleon000000000000#!/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.30/t/compat/env.t000444001750001750 116312240531220 15664 0ustar00leonleon000000000000#!/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.30/t/compat/regression.t000444001750001750 56112240531220 17235 0ustar00leonleon000000000000#!/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.30/t/compat/switches.t000444001750001750 54512240531220 16710 0ustar00leonleon000000000000#!/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.30/lib000755001750001750 012240531220 13571 5ustar00leonleon000000000000Test-Harness-3.30/lib/Test000755001750001750 012240531220 14510 5ustar00leonleon000000000000Test-Harness-3.30/lib/Test/Harness.pm000444001750001750 4014712240531220 16634 0ustar00leonleon000000000000package 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.30 =cut our $VERSION = '3.30'; # 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.30/lib/App000755001750001750 012240531220 14311 5ustar00leonleon000000000000Test-Harness-3.30/lib/App/Prove.pm000444001750001750 4535612240531220 16134 0ustar00leonleon000000000000package App::Prove; use strict; use warnings; use TAP::Harness; 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.30 =cut our $VERSION = '3.30'; =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} = []; } $self->{harness_class} = 'TAP::Harness'; for my $attr (@ATTR) { if ( exists $args->{$attr} ) { # TODO: Some validation here $self->{$attr} = $args->{$attr}; } } my %env_provides_default = ( HARNESS_TIMER => 'timer', ); while ( my ( $env, $attr ) = each %env_provides_default ) { $self->{$attr} = 1 if $ENV{$env}; } $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] }; } return ( \%args, $self->{harness_class} ); } 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, $harness_class, @tests ) = @_; my $harness = $harness_class->new($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'; } push @switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} ) if defined $ENV{HARNESS_PERL_SWITCHES}; 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; 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.30/lib/App/Prove000755001750001750 012240531220 15404 5ustar00leonleon000000000000Test-Harness-3.30/lib/App/Prove/State.pm000444001750001750 2665112240531220 17211 0ustar00leonleon000000000000package 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.30 =cut our $VERSION = '3.30'; =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.30/lib/App/Prove/State000755001750001750 012240531220 16464 5ustar00leonleon000000000000Test-Harness-3.30/lib/App/Prove/State/Result.pm000444001750001750 1152112240531220 20455 0ustar00leonleon000000000000package 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.30 =cut our $VERSION = '3.30'; =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.30/lib/App/Prove/State/Result000755001750001750 012240531220 17742 5ustar00leonleon000000000000Test-Harness-3.30/lib/App/Prove/State/Result/Test.pm000444001750001750 653212240531220 21362 0ustar00leonleon000000000000package App::Prove::State::Result::Test; use strict; use warnings; =head1 NAME App::Prove::State::Result::Test - Individual test results. =head1 VERSION Version 3.30 =cut our $VERSION = '3.30'; =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.30/lib/TAP000755001750001750 012240531220 14215 5ustar00leonleon000000000000Test-Harness-3.30/lib/TAP/Base.pm000444001750001750 414012240531220 15561 0ustar00leonleon000000000000package 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.30 =cut our $VERSION = '3.30'; 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 } 1; Test-Harness-3.30/lib/TAP/Object.pm000444001750001750 521012240531220 16114 0ustar00leonleon000000000000package TAP::Object; use strict; use warnings; =head1 NAME TAP::Object - Base class that provides common functionality to all C modules =head1 VERSION Version 3.30 =cut our $VERSION = '3.30'; =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.30/lib/TAP/Harness.pm000444001750001750 6500712240531220 16343 0ustar00leonleon000000000000package 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.30 =cut our $VERSION = '3.30'; $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 }, 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, all tests are eligible for being 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' }); # Run all tests in parallel, except those starting with "p" $harness->rules({ 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' }, ], }); This is an experimental feature and the interface may change. =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; 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; } } ############################################################################## =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.30/lib/TAP/Parser.pm000444001750001750 14510412240531220 16211 0ustar00leonleon000000000000package 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.30 =cut our $VERSION = '3.30'; 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 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 time when the Parser was created. =head3 C Returns the time 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 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. [1] L [2] L [3] L Test-Harness-3.30/lib/TAP/Harness/Env.pm000444001750001750 736012240531220 17051 0ustar00leonleon000000000000package 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.30'; # 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 = $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.30 =head1 SYNOPSIS my ($class, $args) = get_test_arguments(); require_module($class); $class->new($args); =head1 DESCRIPTION This module implements the environmental variables that L for use with TAP::Harness. =head1 FUNCTIONS =over 4 =item * get_test_options( \%args ) This function reads the environment and generates an appropriate argument hash from it. If given any arguments, there will override the environmental defaults. It will return of C<$class> and C<$args>. =back Test-Harness-3.30/inc000755001750001750 012240531220 13574 5ustar00leonleon000000000000Test-Harness-3.30/inc/MyBuilder.pm000444001750001750 644112240531220 16170 0ustar00leonleon000000000000package MyBuilder; use strict; use warnings; use base qw(Module::Build); # Test with Test::Harness sub ACTION_test_with_harness { my $self = shift; $self->SUPER::ACTION_test(@_); } # Test with TAP::Harness instead of Test::Harness sub ACTION_test { my $self = shift; $self->depends_on('code'); my $tests = $self->find_test_files; unless (@$tests) { $self->log_info("No tests defined.\n"); return; } # TODO verbose and stuff require TAP::Harness; my $harness = TAP::Harness->new( { lib => 'blib/lib' } ); my $aggregator = $harness->runtests(@$tests); die "Failed!\n" if $aggregator->has_problems; } sub ACTION_testprove { my $self = shift; $self->depends_on('code'); exec( $^X, '-Iblib/lib', 'bin/prove', '-b', '-r', 't' ); } sub ACTION_testleaks { my $self = shift; $self->depends_on('code'); exec( $^X, '-MDevel::Leak::Object=GLOBAL_bless', '-Iblib/lib', 'bin/prove', '-b', '-r', 't' ); } sub ACTION_testreference { my $self = shift; $self->depends_on('code'); my $ref = 'reference/Test-Harness-2.64'; exec( $^X, ( -e $ref ? ( "-I$ref/lib", "$ref/bin/prove" ) : qw(-S prove) ), '-Iblib/lib', '-r', 't' ); } sub ACTION_testauthor { my $self = shift; $self->test_files('xt/author'); $self->ACTION_test; } sub ACTION_critic { exec( qw(perlcritic -1 -q -profile perlcriticrc bin/prove lib/), glob('t/*.t') ); } sub ACTION_tags { exec( qw(ctags -f tags --recurse --totals --exclude=blib --exclude=.svn --exclude='*~' --languages=Perl t/ lib/ bin/prove ) ); } sub ACTION_tidy { my $self = shift; my @extra = qw( Build.PL Makefile.PL bin/prove ); my %found_files = map {%$_} $self->find_pm_files, $self->_find_file_by_type( 'pm', 't' ), $self->_find_file_by_type( 'pm', 'inc' ), $self->_find_file_by_type( 't', 't' ); my @files = ( keys %found_files, map { $self->localize_file_path($_) } @extra ); for my $file (@files) { system( 'perltidy', '-b', $file ); unlink("$file.bak") if $? == 0; } } my @profiling_target = qw( -Mblib bin/prove --timer t/regression.t ); sub ACTION_dprof { system( $^X, '-d:DProf', @profiling_target ); exec(qw( dprofpp -R )); } sub ACTION_smallprof { system( $^X, '-d:SmallProf', @profiling_target ); open( FH, 'smallprof.out' ) or die "Can't open smallprof.out: $!"; my @rows = grep {/\d+:/} ; close FH; @rows = reverse sort { ( split( /\s+/, $a ) )[2] <=> ( split( /\s+/, $b ) )[2] } @rows; @rows = @rows[ 0 .. 30 ]; print join( '', @rows ); } sub read_manifest { my ( $self, $file, $into ) = @_; open my $fh, '<', $file or die "Can't read $file: $!"; while (<$fh>) { chomp; s/\s*#.*//; $into->{$_}++ if length $_; } } sub ACTION_manifest { my ( $self, @args ) = @_; $self->SUPER::ACTION_manifest(@args); my $stash = {}; my $mc = 'MANIFEST.CUMMULATIVE'; $self->read_manifest( $mc, $stash ); $self->read_manifest( 'MANIFEST', $stash ); open my $fh, '>', $mc or die "Can't write $mc: $!"; print $fh "$_\n" for sort keys %$stash; } 1; Test-Harness-3.30/examples000755001750001750 012240531220 14641 5ustar00leonleon000000000000Test-Harness-3.30/examples/test_urls.txt000444001750001750 5512240531220 17523 0ustar00leonleon000000000000http://www.google.com/ http://www.yahoo.com/ Test-Harness-3.30/examples/README000444001750001750 415312240531220 15661 0ustar00leonleon000000000000=head1 EXAMPLES =head2 Running Tests in Multiple Languages If you have ruby installed in C, and also have C installed, you can cd into C (the directory where this README lives) and run the following command after installing the C utility: examples $ runtests --exec ./my_exec t -v - < test_urls.txt t/10-stuff..............Failed 1/6 tests (less 2 skipped tests: 3 okay) (1 test unexpectedly succeeded) t/ruby..................ok http://www.google.com/....ok http://www.yahoo.com/.....ok Test Summary Report ------------------- t/10-stuff.t (Wstat: 256 Tests: 6 Failed: 1) Failed tests: 2 TODO passed: 6 uests skipped: 3-4 Files=4, Tests=10, 3 wallclock secs ( 0.92 cusr + 0.23 csys = 1.15 CPU) The C is a Perl program which tells the test harness how to execute any tests it encounters. The C argument tells it to search in the C directory for any tests. One of the tests it finds is written in Ruby, but the C program tells it how to run this test. If you have Ruby installed but the test fails, try changing the path. If you don't have Ruby installed, you can simply comment out those lines in C, but the test will fail. The C<-> tells C to read from C and C is merely a list of URLs we wish to test. See the documentation for C and C for more information about how to use this. The C<-v> tells the harness to run in verbose mode. =head2 Custom Test Harnesses The C harnesses in the C directory are deprecated in favor of the new C/C tools. They are left in primary for curiosity sake, though you may find the C one useful as a reference for how to create a GUI interface for C. Instead, simple override the desired methods in C to create your own custom test harness. Don't like how the summary report is formatted? Just override the C<&TAP::Harness::summary> method and use your new subclass: runtests --harness TAP::Harness::MyHarness Test-Harness-3.30/examples/analyze_tests.pl000444001750001750 405512240531220 20224 0ustar00leonleon000000000000#!/usr/bin/env perl use strict; use warnings; use lib 'lib'; use App::Prove::State; use List::Util 'sum'; use Lingua::EN::Numbers 'num2en'; use Text::Table; use Carp; sub minutes_and_seconds { my $seconds = shift; return ( int( $seconds / 60 ), int( $seconds % 60 ) ); } my $state = App::Prove::State->new( { store => '.prove' } ); my $results = $state->results; my $generation = $results->generation; my @tests = $results->tests; my $total = sum( map { $_->elapsed } @tests ); my ( $minutes, $seconds ) = minutes_and_seconds($total); my $num_tests = shift || 10; my $total_tests = scalar $results->test_names; if ( $num_tests > $total_tests ) { $num_tests = $total_tests; } my $num_word = num2en($num_tests); my %time_for; foreach my $test (@tests) { $time_for{ $test->name } = $test->elapsed; } my @sorted_by_time_desc = sort { $time_for{$b} <=> $time_for{$a} } keys %time_for; print "Number of test programs: $total_tests\n"; print "Total runtime approximately $minutes minutes $seconds seconds\n\n"; print "\u$num_word slowest tests:\n"; my @rows; for ( 0 .. $num_tests - 1 ) { my $test = $sorted_by_time_desc[$_]; my $time = $time_for{$test}; my ( $minutes, $seconds ) = minutes_and_seconds($time); push @rows => [ "${minutes}m ${seconds}s", $test, ]; } print make_table( [qw/Time Test/], \@rows, ); sub make_table { my ( $headers, $rows ) = @_; my @rule = qw(- +); my @headers = \'| '; push @headers => map { $_ => \' | ' } @$headers; pop @headers; push @headers => \' |'; unless ( 'ARRAY' eq ref $rows && 'ARRAY' eq ref $rows->[0] && @$headers == @{ $rows->[0] } ) { croak( "make_table() rows must be an AoA with rows being same size as headers" ); } my $table = Text::Table->new(@headers); $table->rule(@rule); $table->body_rule(@rule); $table->load(@$rows); return $table->rule(@rule), $table->title, $table->rule(@rule), map( { $table->body($_) } 0 .. @$rows ), $table->rule(@rule); } Test-Harness-3.30/examples/my_exec000555001750001750 60312240531220 16334 0ustar00leonleon000000000000#!/usr/bin/perl use strict; use warnings; my $url = qr/^http/; my $prog = shift; if ( $prog !~ $url && !-e $prog ) { die "Cannot find ($prog)"; } my @exec; if ( 't/ruby.t' eq $prog ) { push @exec => '/usr/bin/ruby', $prog; } elsif ( $prog =~ $url ) { push @exec => 'bin/test_html.pl', $prog; } else { push @exec, $prog; } exec @exec or die "Cannot (exec @exec): $!"; Test-Harness-3.30/examples/silent-harness.pl000444001750001750 55712240531220 20261 0ustar00leonleon000000000000#!/usr/bin/perl # # Run some tests and get back a data structure describing them. use strict; use warnings; use TAP::Harness; use Data::Dumper; my @tests = glob 't/yaml*.t'; my $harness = TAP::Harness->new( { verbosity => -9, lib => ['blib/lib'] } ); # $aggregate is a TAP::Parser::Aggregator my $aggregate = $harness->runtests(@tests); print Dumper($aggregate); Test-Harness-3.30/examples/t000755001750001750 012240531220 15104 5ustar00leonleon000000000000Test-Harness-3.30/examples/t/ruby.t000444001750001750 5212240531220 16344 0ustar00leonleon000000000000puts("1..2"); puts("ok 1"); puts("ok 2"); Test-Harness-3.30/examples/t/10-stuff.t000444001750001750 51012240531220 16747 0ustar00leonleon000000000000#!/usr/bin/perl -wT use strict; use warnings; use Test::More qw/no_plan/; ok 1, 'this test passes'; is_deeply [2], [3], 'this is_deeply test fails'; SKIP: { skip 'testing skip', 2 if 1; ok 1; ok 1; } TODO: { local $TODO = 'this is a TODO test'; ok 0, 'This should succeed'; ok 1, 'This should fail'; } Test-Harness-3.30/examples/bin000755001750001750 012240531220 15411 5ustar00leonleon000000000000Test-Harness-3.30/examples/bin/test_html.pl000555001750001750 33612240531220 20073 0ustar00leonleon000000000000#!/usr/bin/perl use strict; use warnings; use Test::More tests => 1; use Test::WWW::Mechanize; my $mech = Test::WWW::Mechanize->new; my $url = shift; $mech->get_ok( $url, "We should be able to fetch ($url)" ); Test-Harness-3.30/examples/bin/tprove_gtk000444001750001750 2544012240531220 17702 0ustar00leonleon000000000000#!/usr/bin/perl -w use strict; use warnings; use File::Find; use IO::Handle; die "Unsupported"; ############################################################################## =head1 NAME tprove_gtk - Simple proof of concept GUI for proving tests =head1 USAGE tprove_gtk [ list of test files ] =head1 DESCRIPTION I've included this in the distribution. It's a gtk interface by Torsten Schoenfeld. I've not run it myself. C is not installed on your system unless you explicitly copy it somewhere in your path. The current incarnation B be run in a directory with both C and C (i.e., the standard "root" level directory in which CPAN style modules are developed). This will probably change in the future. As noted, this is a proof of concept. =head1 CAVEATS This is alpha code. You've been warned. =cut my @tests; if (@ARGV) { @tests = @ARGV; } else { find( sub { -f && /\.t$/ && push @tests => $File::Find::name }, "t" ); } pipe( my $reader, my $writer ); # Unfortunately, autoflush-ing seems to be a big performance problem. If you # don't care about "real-time" progress bars, turn this off. $writer->autoflush(1); if ( my $pid = fork ) { close $writer; my $gui = Gui->new( $pid, $reader ); $gui->add_tests(@tests); $gui->run(); } else { die "Cannot fork: $!" unless defined $pid; close $reader; my $runner = TestRunner->new($writer); $runner->add_tests(@tests); $runner->run(); close $writer; } ############################################################################### # --------------------------------------------------------------------------- # ############################################################################### package Gui; use Glib qw(TRUE FALSE); use Gtk2 -init; use constant { COLUMN_FILENAME => 0, COLUMN_TOTAL => 1, COLUMN_RUN => 2, COLUMN_PASS => 3, COLUMN_FAIL => 4, COLUMN_SKIP => 5, COLUMN_TODO => 6, }; BEGIN { if ( !Gtk2->CHECK_VERSION( 2, 6, 0 ) ) { die("$0 needs gtk+ >= 2.6"); } } DESTROY { my ($self) = @_; if ( defined $self->{reader_source} ) { Glib::Source->remove( $self->{reader_source} ); } } sub new { my ( $class, $child_pid, $reader ) = @_; my $self = bless {}, $class; $self->create_window(); $self->create_menu(); $self->create_view(); $self->{child_pid} = $child_pid; $self->{child_running} = TRUE; $self->{reader_source} = Glib::IO->add_watch( fileno $reader, [qw(in pri hup)], \&_callback_reader, $self ); return $self; } sub add_tests { my ( $self, @tests ) = @_; my $model = $self->{_model}; $self->{_path_cache} = {}; foreach my $test (@tests) { my $iter = $model->append(); $model->set( $iter, COLUMN_FILENAME, $test ); $self->{_path_cache}->{$test} = $model->get_path($iter); } } sub create_window { my ($self) = @_; my $window = Gtk2::Window->new(); my $vbox = Gtk2::VBox->new( FALSE, 5 ); $window->add($vbox); $window->set_title("Test Runner"); $window->set_default_size( 300, 600 ); $window->signal_connect( delete_event => \&_callback_quit, $self ); $self->{_window} = $window; $self->{_vbox} = $vbox; } sub create_menu { my ($self) = @_; my $window = $self->{_window}; my $vbox = $self->{_vbox}; my $ui = <<"UI"; UI my $actions = [ [ "test_menu", undef, "_Tests" ], [ "quit_item", "gtk-quit", "_Quit", "Q", "Quit the test runner", sub { _callback_quit( undef, undef, $self ) }, ], ]; my $action_group = Gtk2::ActionGroup->new("main"); $action_group->add_actions($actions); my $manager = Gtk2::UIManager->new(); $manager->insert_action_group( $action_group, 0 ); $manager->add_ui_from_string($ui); my $menu_box = Gtk2::VBox->new( FALSE, 0 ); $manager->signal_connect( add_widget => sub { my ( $manager, $widget ) = @_; $menu_box->pack_start( $widget, FALSE, FALSE, 0 ); } ); $vbox->pack_start( $menu_box, FALSE, FALSE, 0 ); $window->add_accel_group( $manager->get_accel_group() ); $self->{_manager} = $manager; } sub create_view { my ($self) = @_; my $window = $self->{_window}; my $vbox = $self->{_vbox}; my $scroller = Gtk2::ScrolledWindow->new(); $scroller->set_policy( "never", "automatic" ); my $model = Gtk2::ListStore->new( # filename total run pass fail skip todo qw(Glib::String Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int) ); my $view = Gtk2::TreeView->new($model); # ------------------------------------------------------------------------- # my $column_filename = Gtk2::TreeViewColumn->new_with_attributes( "Filename", Gtk2::CellRendererText->new(), text => COLUMN_FILENAME ); $column_filename->set_sizing("autosize"); $column_filename->set_expand(TRUE); $view->append_column($column_filename); # ------------------------------------------------------------------------- # my $renderer_progress = Gtk2::CellRendererProgress->new(); my $column_progress = Gtk2::TreeViewColumn->new_with_attributes( "Progress", $renderer_progress ); $column_progress->set_cell_data_func( $renderer_progress, sub { my ( $column, $renderer, $model, $iter ) = @_; my ( $total, $run ) = $model->get( $iter, COLUMN_TOTAL, COLUMN_RUN ); if ( $run == 0 ) { $renderer->set( text => "", value => 0 ); return; } if ( $total != 0 ) { $renderer->set( text => "$run/$total", value => $run / $total * 100 ); } else { $renderer->set( text => $run, value => 0 ); } } ); $view->append_column($column_progress); # ------------------------------------------------------------------------- # my @count_columns = ( [ "Pass", COLUMN_PASS ], [ "Fail", COLUMN_FAIL ], [ "Skip", COLUMN_SKIP ], [ "Todo", COLUMN_TODO ], ); foreach (@count_columns) { my ( $heading, $column_number ) = @{$_}; my $renderer = Gtk2::CellRendererText->new(); $renderer->set( xalign => 1.0 ); my $column = Gtk2::TreeViewColumn->new_with_attributes( $heading, $renderer, text => $column_number ); $view->append_column($column); } # ------------------------------------------------------------------------- # $scroller->add($view); $vbox->pack_start( $scroller, TRUE, TRUE, 0 ); $self->{_view} = $view; $self->{_model} = $model; } sub run { my ($self) = @_; $self->{_window}->show_all(); Gtk2->main(); } # --------------------------------------------------------------------------- # sub _callback_reader { my ( $fileno, $condition, $self ) = @_; if ( $condition & "in" || $condition & "pri" ) { my $data = <$reader>; if ( $data !~ /^[^\t]+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+$/x ) { return TRUE; } my ( $filename, $total, $run, $pass, $fail, $skip, $todo ) = split /\t/, $data; my $view = $self->{_view}; my $model = $self->{_model}; my $path_cache = $self->{_path_cache}; if ( $path_cache->{$filename} ) { my $iter = $model->get_iter( $path_cache->{$filename} ); $model->set( $iter, COLUMN_TOTAL, $total, COLUMN_RUN, $run, COLUMN_PASS, $pass, COLUMN_FAIL, $fail, COLUMN_SKIP, $skip, COLUMN_TODO, $todo ); $view->scroll_to_cell( $path_cache->{$filename} ); } } elsif ( $condition & "hup" ) { $self->{child_running} = FALSE; return FALSE; } else { warn "got unknown condition: $condition"; return FALSE; } return TRUE; } sub _callback_quit { my ( $window, $event, $self ) = @_; if ( $self->{child_running} ) { kill "TERM", $self->{child_pid}; } Gtk2->main_quit(); } ############################################################################### # --------------------------------------------------------------------------- # ############################################################################### package TestRunner; use TAP::Parser; use TAP::Parser::Source::Perl; use constant { INDEX_TOTAL => 0, INDEX_RUN => 1, INDEX_PASS => 2, INDEX_FAIL => 3, INDEX_SKIP => 4, INDEX_TODO => 5, }; sub new { my ( $class, $writer ) = @_; my $self = bless {}, $class; $self->{_writer} = $writer; return $self; } sub add_tests { my ( $self, @tests ) = @_; $self->{_tests} = [@tests]; $self->{_results} = {}; foreach my $test ( @{ $self->{_tests} } ) { $self->{_results}->{$test} = [ 0, 0, 0, 0, 0, 0 ]; } } sub run { my ($self) = @_; my $source = TAP::Parser::Source::Perl->new(); foreach my $test ( @{ $self->{_tests} } ) { my $parser = TAP::Parser->new( { source => $test } ); $self->analyze( $test, $parser ) if $parser; } my $writer = $self->{_writer}; $writer->flush(); $writer->print("\n"); } sub analyze { my ( $self, $test, $parser ) = @_; my $writer = $self->{_writer}; my $result = $self->{_results}->{$test}; while ( my $line = $parser->next() ) { if ( $line->is_plan() ) { $result->[INDEX_TOTAL] = $line->tests_planned(); } elsif ( $line->is_test() ) { $result->[INDEX_RUN]++; if ( $line->has_skip() ) { $result->[INDEX_SKIP]++; next; } if ( $line->has_todo() ) { $result->[INDEX_TODO]++; } if ( $line->is_ok() ) { $result->[INDEX_PASS]++; } else { $result->[INDEX_FAIL]++; } } elsif ( $line->is_comment() ) { # ignore } else { warn "Unknown result type `" . $line->type() . "´: " . $line->as_string(); } my $string = join "\t", $test, @{$result}; $writer->print("$string\n"); } return $parser; } Test-Harness-3.30/examples/bin/forked_tests.pl000444001750001750 312412240531220 20577 0ustar00leonleon000000000000#!/usr/bin/perl # Run tests in parallel. This just allows you to check that your tests # are roughly capable of running in parallel. It writes output to a # tree in /tmp. # From: Eric Wilhelm @ ewilhelm at cpan.org use warnings; use strict; use File::Basename (); use File::Path (); use List::Util (); my @tests = @ARGV; #@tests = List::Util::shuffle(@tests); use POSIX (); my %map; my $i = 0; my $jobs = 9; # scalar(@tests); # if you like forkbombs my @running; while (@tests) { if ( $jobs == @running ) { my @list; while ( my $pid = shift(@running) ) { if ( waitpid( $pid, POSIX::WNOHANG() ) > 0 ) { warn ' ' x 25 . "done $map{$pid}\n"; next; } push( @list, $pid ); } #warn "running ", scalar(@list); @running = @list; next; } my $test = shift(@tests); defined( my $pid = fork ) or die; $i++; if ($pid) { push( @running, $pid ); $map{$pid} = $test; print "$test\n"; } else { my $dest_base = '/tmp'; my $dest_dir = File::Basename::dirname("$dest_base/$test"); unless ( -d $dest_dir ) { File::Path::mkpath($dest_dir) or die; } $| = 1; open( STDOUT, '>', "$dest_base/$test.out" ) or die; open( STDERR, '>', "$dest_base/$test.err" ) or die; exec( $^X, '-Ilib', $test ); } } my $v = 0; until ( $v == -1 ) { $v = wait; ( $v == -1 ) and last; $? and warn "$map{$v} ($v) no happy $?"; } print "bye\n"; # vim:ts=2:sw=2:et:sta Test-Harness-3.30/examples/harness-hook000755001750001750 012240531220 17242 5ustar00leonleon000000000000Test-Harness-3.30/examples/harness-hook/hook.pl000555001750001750 46112240531220 20660 0ustar00leonleon000000000000#!/usr/bin/perl use strict; use warnings; use lib qw( lib ../../lib ); use Harness::Hook; use TAP::Harness; use File::Spec; $| = 1; my $harness = TAP::Harness->new; # Install the hook Harness::Hook->new($harness); $harness->runtests( File::Spec->catfile( split( /\//, '../../t/000-load.t' ) ) ); Test-Harness-3.30/examples/harness-hook/lib000755001750001750 012240531220 20010 5ustar00leonleon000000000000Test-Harness-3.30/examples/harness-hook/lib/Harness000755001750001750 012240531220 21413 5ustar00leonleon000000000000Test-Harness-3.30/examples/harness-hook/lib/Harness/Hook.pm000444001750001750 74312240531220 22772 0ustar00leonleon000000000000package Harness::Hook; use strict; use warnings; use Carp; sub new { my ( $class, $harness ) = @_; my $self = bless {}, $class; $harness->callback( 'before_runtests', sub { my ($aggregate) = @_; warn "Before runtests\n"; } ); $harness->callback( 'after_runtests', sub { my ( $aggregate, $results ) = @_; warn "After runtests\n"; } ); return $self; } 1; Test-Harness-3.30/bin000755001750001750 012240531220 13573 5ustar00leonleon000000000000Test-Harness-3.30/bin/prove000555001750001750 3214512240531220 15036 0ustar00leonleon000000000000#!/usr/bin/perl -w use strict; use warnings; use App::Prove; my $app = App::Prove->new; $app->process_args(@ARGV); exit( $app->run ? 0 : 1 ); __END__ =head1 NAME prove - Run tests through a TAP harness. =head1 USAGE prove [options] [files or directories] =head1 OPTIONS Boolean options: -v, --verbose Print all test lines. -l, --lib Add 'lib' to the path for your tests (-Ilib). -b, --blib Add 'blib/lib' and 'blib/arch' to the path for your tests -s, --shuffle Run the tests in random order. -c, --color Colored test output (default). --nocolor Do not color test output. --count Show the X/Y test count when not verbose (default) --nocount Disable the X/Y test count. -D --dry Dry run. Show test that would have run. -f, --failures Show failed tests. -o, --comments Show comments. --ignore-exit Ignore exit status from test scripts. -m, --merge Merge test scripts' STDERR with their STDOUT. -r, --recurse Recursively descend into directories. --reverse Run the tests in reverse order. -q, --quiet Suppress some test output while running tests. -Q, --QUIET Only print summary results. -p, --parse Show full list of TAP parse errors, if any. --directives Only show results with TODO or SKIP directives. --timer Print elapsed time after each test. --trap Trap Ctrl-C and print summary on interrupt. --normalize Normalize TAP output in verbose output -T Enable tainting checks. -t Enable tainting warnings. -W Enable fatal warnings. -w Enable warnings. -h, --help Display this help -?, Display this help -H, --man Longer manpage for prove --norc Don't process default .proverc Options that take arguments: -I Library paths to include. -P Load plugin (searches App::Prove::Plugin::*.) -M Load a module. -e, --exec Interpreter to run the tests ('' for compiled tests.) --ext Set the extension for tests (default '.t') --harness Define test harness to use. See TAP::Harness. --formatter Result formatter to use. See FORMATTERS. --source Load and/or configure a SourceHandler. See SOURCE HANDLERS. -a, --archive out.tgz Store the resulting TAP in an archive file. -j, --jobs N Run N test jobs in parallel (try 9.) --state=opts Control prove's persistent state. --rc=rcfile Process options from rcfile --rules Rules for parallel vs sequential processing. =head1 NOTES =head2 .proverc If F<~/.proverc> or F<./.proverc> exist they will be read and any options they contain processed before the command line options. Options in F<.proverc> are specified in the same way as command line options: # .proverc --state=hot,fast,save -j9 Additional option files may be specified with the C<--rc> option. Default option file processing is disabled by the C<--norc> option. Under Windows and VMS the option file is named F<_proverc> rather than F<.proverc> and is sought only in the current directory. =head2 Reading from C If you have a list of tests (or URLs, or anything else you want to test) in a file, you can add them to your tests by using a '-': prove - < my_list_of_things_to_test.txt See the C in the C directory of this distribution. =head2 Default Test Directory If no files or directories are supplied, C looks for all files matching the pattern C. =head2 Colored Test Output Colored test output using L is the default, but if output is not to a terminal, color is disabled. You can override this by adding the C<--color> switch. Color support requires L on Unix-like platforms and L on windows. If the necessary module is not installed colored output will not be available. =head2 Exit Code If the tests fail C will exit with non-zero status. =head2 Arguments to Tests It is possible to supply arguments to tests. To do so separate them from prove's own arguments with the arisdottle, '::'. For example prove -v t/mytest.t :: --url http://example.com would run F with the options '--url http://example.com'. When running multiple tests they will each receive the same arguments. =head2 C<--exec> Normally you can just pass a list of Perl tests and the harness will know how to execute them. However, if your tests are not written in Perl or if you want all tests invoked exactly the same way, use the C<-e>, or C<--exec> switch: prove --exec '/usr/bin/ruby -w' t/ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/ prove --exec '/path/to/my/customer/exec' =head2 C<--merge> If you need to make sure your diagnostics are displayed in the correct order relative to test results you can use the C<--merge> option to merge the test scripts' STDERR into their STDOUT. This guarantees that STDOUT (where the test results appear) and STDERR (where the diagnostics appear) will stay in sync. The harness will display any diagnostics your tests emit on STDERR. Caveat: this is a bit of a kludge. In particular note that if anything that appears on STDERR looks like a test result the test harness will get confused. Use this option only if you understand the consequences and can live with the risk. =head2 C<--trap> The C<--trap> option will attempt to trap SIGINT (Ctrl-C) during a test run and display the test summary even if the run is interrupted =head2 C<--state> You can ask C to remember the state of previous test runs and select and/or order the tests to be run based on that saved state. The C<--state> switch requires an argument which must be a comma separated list of one or more of the following options. =over =item C Run the same tests as the last time the state was saved. This makes it possible, for example, to recreate the ordering of a shuffled test. # Run all tests in random order $ prove -b --state=save --shuffle # Run them again in the same order $ prove -b --state=last =item C Run only the tests that failed on the last run. # Run all tests $ prove -b --state=save # Run failures $ prove -b --state=failed If you also specify the C option newly passing tests will be excluded from subsequent runs. # Repeat until no more failures $ prove -b --state=failed,save =item C Run only the passed tests from last time. Useful to make sure that no new problems have been introduced. =item C Run all tests in normal order. Multple options may be specified, so to run all tests with the failures from last time first: $ prove -b --state=failed,all,save =item C Run the tests that most recently failed first. The last failure time of each test is stored. The C option causes tests to be run in most-recent- failure order. $ prove -b --state=hot,save Tests that have never failed will not be selected. To run all tests with the most recently failed first use $ prove -b --state=hot,all,save This combination of options may also be specified thus $ prove -b --state=adrian =item C Run any tests with todos. =item C Run the tests in slowest to fastest order. This is useful in conjunction with the C<-j> parallel testing switch to ensure that your slowest tests start running first. $ prove -b --state=slow -j9 =item C Run test tests in fastest to slowest order. =item C Run the tests in newest to oldest order based on the modification times of the test scripts. =item C Run the tests in oldest to newest order. =item C Run those test scripts that have been modified since the last test run. =item C Save the state on exit. The state is stored in a file called F<.prove> (F<_prove> on Windows and VMS) in the current directory. =back The C<--state> switch may be used more than once. $ prove -b --state=hot --state=all,save =head2 --rules The C<--rules> option is used to control which tests are run sequentially and which are run in parallel, if the C<--jobs> option is specified. The option may be specified multiple times, and the order matters. The most practical use is likely to specify that some tests are not "parallel-ready". Since mentioning a file with --rules doesn't cause it to be selected to run as a test, you can "set and forget" some rules preferences in your .proverc file. Then you'll be able to take maximum advantage of the performance benefits of parallel testing, while some exceptions are still run in parallel. =head3 --rules examples # All tests are allowed to run in parallel, except those starting with "p" --rules='seq=t/p*.t' --rules='par=**' # All tests must run in sequence except those starting with "p", which should be run parallel --rules='par=t/p*.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 them run in parallel. You still need specify the number of parallel C in your Harness object. =back =head3 --rules Glob-style pattern matching We implement our own glob-style pattern matching for --rules. Here are the supported patterns: ** 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 =head3 More advanced specifications for parallel vs sequence run rules If you need more advanced management of what runs in parallel vs in sequence, see the associated 'rules' documentation in L and L. If what's possible directly through C is not sufficient, you can write your own harness to access these features directly. =head2 @INC prove introduces a separation between "options passed to the perl which runs prove" and "options passed to the perl which runs tests"; this distinction is by design. Thus the perl which is running a test starts with the default C<@INC>. Additional library directories can be added via the C environment variable, via -Ifoo in C or via the C<-Ilib> option to F. =head2 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> prove passes the names of any directories found in C as -I switches. The net effect of this is that C is honoured even when prove is run in taint mode. =head1 FORMATTERS You can load a custom L: prove --formatter MyFormatter =head1 SOURCE HANDLERS You can load custom Ls, to change the way the parser interprets particular I of TAP. prove --source MyHandler --source YetAnother t If you want to provide config to the source you can use: prove --source MyCustom \ --source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \ --source File --file-option extensions=.txt --file-option extensions=.tmp t --source pgTAP --pgtap-option pset=format=html --pgtap-option pset=border=2 Each C<--$source-option> option must specify a key/value pair separated by an C<=>. If an option can take multiple values, just specify it multiple times, as with the C examples above. If the option should be a hash reference, specify the value as a second pair separated by a C<=>, as in the C examples above (escape C<=> with a backslash). All C<--sources> are combined into a hash, and passed to L's C parameter. See L for more details on how configuration is passed to I. =head1 PLUGINS Plugins can be loaded using the C<< -PI >> syntax, 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 arguments to your plugin by appending C<=arg1,arg2,etc> to the plugin name: prove -PMyPlugin=fou,du,fafa Please check individual plugin documentation for more details. =head2 Available Plugins For an up-to-date list of plugins available, please check CPAN: L =head2 Writing Plugins Please see L. =cut # vim:ts=4:sw=4:et:sta Test-Harness-3.30/xt000755001750001750 012240531220 13456 5ustar00leonleon000000000000Test-Harness-3.30/xt/perls000755001750001750 012240531220 14603 5ustar00leonleon000000000000Test-Harness-3.30/xt/perls/harness_perl.t000555001750001750 332612240531220 17621 0ustar00leonleon000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; # TODO we need to have some way to find one or more alternate versions # of perl on the smoke machine so that we can verify that the installed # perl can be used to test against the alternate perls without # installing the harness in the alternate perls. Does that make sense? # # Example: # harness process (i.e. bin/prove) is perl 5.8.8. # subprocesses (i.e. t/test.t) are perl 5.6.2. my @perls; BEGIN { my $perls_live_at = '/usr/local/stow/'; @perls = grep( { -e $_ } map( {"$perls_live_at/perl-$_/bin/perl"} qw(5.5.4 5.6.2) ) ); if (@perls) { plan( tests => scalar(@perls) * 4 ); } else { plan( skip_all => "no perls found in '$perls_live_at'" ); } } use File::Temp (); use File::Path (); use IPC::Run (); mkdir('twib') or die "cannot create 'twib' $!"; { # create a lib open( my $fh, '>', 'twib/foo.pm' ); print $fh "package twib;\nsub foo {'bar';}\n1;\n"; } END { File::Path::rmtree('twib'); } my @tests = qw( xt/perls/sample-tests/perl_version ); # TODO and something with taint # make the tests check that the perl is indeed the $perl (thus they are # just printed tests.) for my $perl (@perls) { # TODO make the API be *not* an environment variable! local $ENV{HARNESS_PERL} = $perl; my ( $in, $out, $err ) = ( undef, '', '' ); my $ret = IPC::Run::run( [ $^X, '-Ilib', 'bin/prove', '-It/lib', '-Itwib', @tests ], \$in, \$out, \$err ); ok( $ret, 'no death' ); like( $out, qr/All tests successful/, 'success' ); like( $out, qr/Result: PASS/, 'passed' ); is($err, '', 'no error'); } # vim:ts=4:sw=4:et:sta Test-Harness-3.30/xt/perls/sample-tests000755001750001750 012240531220 17224 5ustar00leonleon000000000000Test-Harness-3.30/xt/perls/sample-tests/perl_version000444001750001750 26212240531220 21773 0ustar00leonleon000000000000use Test::More tests => 2; isn::t( $ENV{HARNESS_VERSION}, $], 'different perl' ); my @twib = grep( /\btwib\b/, @INC ); is( scalar(@twib), 1, 'got my twib lib' ) or warn "@INC"; Test-Harness-3.30/xt/author000755001750001750 012240531220 14760 5ustar00leonleon000000000000Test-Harness-3.30/xt/author/pod-coverage.t000555001750001750 71212240531220 17640 0ustar00leonleon000000000000#!perl -w use strict; use warnings; use lib 't/lib'; use Test::More; # TODO skip on install? eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; # this isn't perfect, but it's close enough my @deprecated = qw( actual_passed good_plan passed ); local $^W; # we want it to ignore 'Test::Builder::failure_output redefined' all_pod_coverage_ok( { trustme => \@deprecated } ); Test-Harness-3.30/xt/author/pod.t000555001750001750 32212240531220 16044 0ustar00leonleon000000000000#!perl -wT use strict; use warnings; use lib 't/lib'; use Test::More; # TODO skip on install? eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); Test-Harness-3.30/xt/author/stdin.t000444001750001750 20012240531220 16373 0ustar00leonleon000000000000#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More tests => 1; ok -t STDIN, 'STDIN remains a TTY';