Test-Harness-3.48/0000755000175000017500000000000014506607710013022 5ustar leontleontTest-Harness-3.48/perlcriticrc0000644000175000017500000000131212166360606015427 0ustar leontleont[-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.48/README0000644000175000017500000000066013544726327013713 0ustar leontleontTest-Harness 3.24 INSTALLATION To install Test::Harness using ExtUtils::MakeMaker do: perl Makefile.PL make make test make 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.48/META.yml0000644000175000017500000000140614506607710014274 0ustar leontleont--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' 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 no_index: directory: - t - inc recommends: Pod::Usage: '1.12' requires: {} resources: bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness homepage: http://testanything.org/ repository: http://github.com/Perl-Toolchain-Gang/Test-Harness/tree/master version: '3.48' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Test-Harness-3.48/Makefile.PL0000644000175000017500000000430414474363573015007 0ustar leontleont#!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' }, 'EXE_FILES' => ['bin/prove'], 'PREREQ_PM' => {}, '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' ], recommends => { 'Pod::Usage' => '1.12', # for 'prove' }, }, ); { no warnings; 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 ); } sub postamble { return <<"END"; testprove: pure_all $^X -Iblib/lib bin/prove -b -r t testleaks: pure_all $^X -MDevel::Leak::Object=GLOBAL_bless -Iblib/lib bin/prove -b -r t testreference: pure_all $^X -Ireference/Test-Harness-2.64/lib reference/Test-Harness-2.64/bin/prove -Iblib/lib -r t testauthor: pure_all $^X -Iblib/lib bin/prove -b -r xt critic: perlcritic -1 -q -profile perlcriticrc bin/prove lib/ t/*.t tags: ctags -f tags --recurse --totals --exclude=blib --exclude=.git --exclude='*~' --languages=Perl t/ lib/ bin/prove tidy: (find lib t -name *.pm; find t -name *.t; echo Makefile.PL; echo bin/prove) | while read a; do perltidy -b \$\$a && rm \$\$a.bak; done; END } Test-Harness-3.48/Changes0000644000175000017500000012637114506607631014331 0ustar leontleontRevision history for Test-Harness 3.48 2023-10-02 - Accept TAP version 14 3.47 2023-08-13 - Add missing negation in EINTR check - Fix HARNESS_PERL_SWITCHES=-I handling in TAP::Harness::Env 3.46 2023-07-30 - Color the "ok"s as well. - Skip symlink tests on msys2 - Use use absolute path for executable tests - Space-quote executable if has spaces - Avoid using Errno::EINTR directly for platforms without it - stop calling import on App::Prove plugins 3.45_02 2023-06-01 - Avoid using Errno::EINTR directly for platforms without it 3.45_01 28-04-2023 - Color the "ok"s as well. - Skip symlink tests on msys2 - Use use absolute path for executable tests - Space-quote executable if has spaces 3.44 17-04-2022 - Release 3.43_06 as non-dev 3.43_06 11-04-2022 - Fix skipping SEGV test 3.43_05 07-04-2022 - Fix failing SEGV test on Windows 3.43_04 22-01-2022 - Remove ASCII-isms to better work on EBCDIC 3.43_03 30-07-2021 - Move timer initialization - Fix YAMLish behaviour with empty values - fix eintr error handling in TAP::Parser::Multiplexer - Parse out signal name & core dump. 3.43_02 25-03-2020 - Let the aggregator finish gracefully after bailout - Make prove respect HARNESS_VERBOSE if no verbosity flags are passed 3.42 19-03-2018 - Enable rulesfile.t to run in core 3.41 27-02-2018 - Released 3.40_01 without code modifications 3.40_01 23-07-2017 - Return handle for pipes and sockets #58 (Erik Huelsmann) - TAP v13 plan allows trailing whitespace (Steffen Schwigon) - prove: add a --statefile= option to customize the .prove file (Ævar Arnfjörð Bjarmason) - Avoid non-deterministic source handling, make a SourceHandler tie an error. (Michael Schwern, Leon Timmermans) - Fix and simplify MSWin32 colorization (Roy Ivy III) - Fix file source handler to accept single extensions option (Tomoki Aonuma) - Spelling fixes (Brian Wightman) 3.39 06-04-2017 - Make tests pass when PERL_USE_UNSAFE_INC=0 3.38 13-03-2017 - Released 3.37_01 without changes 3.37_01 - Set PERL_USE_UNSAFE_INC when running tests using Test::Harness (Leon Timmermans) - Avoid loading optional modules from . in prove 3.36 30-12-2015 - Accept YAML with trailing whitespace in header (Maik Hentsche) - Stop bundling Test::More for testing 3.35 2015-01-14 - Fix prove --version to actually print the version (Leon Timmermans, #101216) - Add --version to usage message (Leon Timmermans, #101215) 3.34 2014-11-02 - Enable printing CPU times spent per test (Jarkko Hietaniemi) 3.33 2014-08-16 - Various documentation fixes (Leon Timmermans, Justin Cook) 3.32 2014-06-11 - Remove harness_class from argument hash in T::H::E (Leon Timmermans) 3.31 2014-06-07 - Implement external rulesfile for TAP::Harness (David Golden) - Add harness_class argument to TAP::Harness::Env (Leon Timmermans) - Make prove respect environmental variables #28 (Leon Timmermans) 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.48/bin/0000755000175000017500000000000014506607710013572 5ustar leontleontTest-Harness-3.48/bin/prove0000755000175000017500000003241514424057335014661 0ustar leontleont#!/usr/bin/perl -w BEGIN { pop @INC if $INC[-1] eq '.' } 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. Also sets TEST_VERBOSE -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 -V, --version Display the version -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. --statefile=file Use `file` instead of `.prove` for 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 and, on windows platforms, also L. If the necessary module(s) are 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. Multiple 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.48/examples/0000755000175000017500000000000014506607710014640 5ustar leontleontTest-Harness-3.48/examples/README0000644000175000017500000000415312166360606015523 0ustar leontleont=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.48/examples/test_urls.txt0000644000175000017500000000005512166360606017425 0ustar leontleonthttp://www.google.com/ http://www.yahoo.com/ Test-Harness-3.48/examples/analyze_tests.pl0000644000175000017500000000405512166360606020066 0ustar leontleont#!/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.48/examples/harness-hook/0000755000175000017500000000000014506607710017241 5ustar leontleontTest-Harness-3.48/examples/harness-hook/hook.pl0000755000175000017500000000046112765211622020540 0ustar leontleont#!/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.48/examples/harness-hook/lib/0000755000175000017500000000000014506607710020007 5ustar leontleontTest-Harness-3.48/examples/harness-hook/lib/Harness/0000755000175000017500000000000014506607710021412 5ustar leontleontTest-Harness-3.48/examples/harness-hook/lib/Harness/Hook.pm0000644000175000017500000000074312166360606022654 0ustar leontleontpackage 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.48/examples/silent-harness.pl0000644000175000017500000000055712166360606020143 0ustar leontleont#!/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.48/examples/bin/0000755000175000017500000000000014506607710015410 5ustar leontleontTest-Harness-3.48/examples/bin/tprove_gtk0000644000175000017500000002544012220024750017510 0ustar leontleont#!/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.48/examples/bin/test_html.pl0000755000175000017500000000033612765211622017753 0ustar leontleont#!/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.48/examples/bin/forked_tests.pl0000644000175000017500000000312412166360606020441 0ustar leontleont#!/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.48/examples/t/0000755000175000017500000000000014506607710015103 5ustar leontleontTest-Harness-3.48/examples/t/10-stuff.t0000644000175000017500000000051012220024750016615 0ustar leontleont#!/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.48/examples/t/ruby.t0000644000175000017500000000005212166360606016246 0ustar leontleontputs("1..2"); puts("ok 1"); puts("ok 2"); Test-Harness-3.48/examples/my_exec0000755000175000017500000000060312765211622016214 0ustar leontleont#!/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.48/xt/0000755000175000017500000000000014506607710013455 5ustar leontleontTest-Harness-3.48/xt/perls/0000755000175000017500000000000014506607710014602 5ustar leontleontTest-Harness-3.48/xt/perls/sample-tests/0000755000175000017500000000000014506607710017223 5ustar leontleontTest-Harness-3.48/xt/perls/sample-tests/perl_version0000644000175000017500000000026212166360606021655 0ustar leontleontuse 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.48/xt/perls/harness_perl.t0000755000175000017500000000332612765211622017461 0ustar leontleont#!/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.48/xt/author/0000755000175000017500000000000014506607710014757 5ustar leontleontTest-Harness-3.48/xt/author/pod-coverage.t0000755000175000017500000000071212765211622017520 0ustar leontleont#!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.48/xt/author/pod.t0000755000175000017500000000032212765211622015724 0ustar leontleont#!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.48/xt/author/stdin.t0000644000175000017500000000020012220024750016241 0ustar leontleont#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More tests => 1; ok -t STDIN, 'STDIN remains a TTY'; Test-Harness-3.48/t/0000755000175000017500000000000014506607710013265 5ustar leontleontTest-Harness-3.48/t/000-load.t0000644000175000017500000000403313135104142014652 0ustar leontleont#!/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.48/t/harness-subclass.t0000644000175000017500000000312113135104127016716 0ustar leontleont#!/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.48/t/source.t0000755000175000017500000002057014250630440014751 0ustar leontleont#!/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 $symlink_exists = 0 if $^O eq 'msys'; # 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; my $did_symlink = eval { symlink( File::Spec->rel2abs($test), $symlink ) }; if ( my $e = $@ ) { diag($@); die "aborting test"; } skip "symlink not successful: $!", 9 unless $did_symlink; $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.48/t/rulesfile.t0000644000175000017500000000370013255673524015452 0ustar leontleont#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use TAP::Harness; use Test::More; use File::Path qw/mkpath rmtree/; use File::Spec::Functions qw/catdir catfile rel2abs/; for my $path (@INC) { $path = rel2abs($path); } if ( eval { require CPAN::Meta::YAML; 1 } ) { plan tests => 4; } else { plan skip_all => "requires CPAN::Meta::YAML"; } # create temp directories long-hand # XXX should we add File::Temp as a prereq to do this? my $initial_dir = rel2abs("."); my $work_dir = catdir($initial_dir, "tmp" . int(rand(2**31))); my $t_dir = catdir($work_dir, 't'); mkpath($t_dir) or die "Could not create $t_dir: $!"; chdir $work_dir; # clean up at the end, but only if we didn't skip END { if ($initial_dir) {chdir $initial_dir; rmtree($work_dir) } } # Create test rules in t { open my $fh, ">", catfile($t_dir, "testrules.yml"); print {$fh} <<'HERE'; --- par: t/p*.t HERE close $fh; } my $th = TAP::Harness->new; my $exp = { par => 't/p*.t' }; is_deeply( $th->rules, $exp, "rules set from t/testrules.yml" ); # Create test rules in dist root { open my $fh, ">", catfile($work_dir, "testrules.yml"); print {$fh} <<'HERE'; --- seq: - seq: t/p*.t - par: '**' HERE close $fh; } $th = TAP::Harness->new; $exp = { seq => [ { seq => 't/p*.t' }, { par => '**' }, ], }; is_deeply( $th->rules, $exp, "root testrules.yml overrides t/testrules.yml" ); # Create alternately named file my $altrules = catfile($work_dir, "myrules.yml"); { open my $fh, ">", $altrules; print {$fh} <<'HERE'; --- seq: ** HERE close $fh; } { local $ENV{HARNESS_RULESFILE} = $altrules; $th = TAP::Harness->new; $exp = { seq => '**' }; is_deeply( $th->rules, $exp, "HARNESS_RULESFILE overrides testrules.yml" ); } $th = TAP::Harness->new( { rulesfile => $altrules} ); $exp = { seq => '**' }; is_deeply( $th->rules, $exp, "rulesfile param overrides testrules.yml" ); Test-Harness-3.48/t/errors.t0000644000175000017500000001122313135104143014752 0ustar leontleont#!/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.48/t/nofork.t0000755000175000017500000000306413361463034014753 0ustar leontleont#!/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.48/t/iterators.t0000644000175000017500000001326713361463034015474 0ustar leontleont#!/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.48/t/aggregator.t0000644000175000017500000002254613135104144015573 0ustar leontleont#!/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.48/t/sample-tests/0000755000175000017500000000000014506607710015706 5ustar leontleontTest-Harness-3.48/t/sample-tests/skipall_v130000644000175000017500000000010412166360606017754 0ustar leontleontprint <>= 1; print shift @parts; } sleep $delay if ( $delay_at & 1 ); Test-Harness-3.48/t/sample-tests/bignum_many0000644000175000017500000000017312166360606020137 0ustar leontleontprint < 1; eval { `$^X -e1` }; like( $@, '/^Insecure dependency/', '-T honored' ); Test-Harness-3.48/t/sample-tests/junk_before_plan0000644000175000017500000000011212166360606021126 0ustar leontleontprint < 1; ok 23, 42; Test-Harness-3.48/t/sample-tests/inc_taint0000644000175000017500000000012212166360606017574 0ustar leontleont#!/usr/bin/perl -Tw use Test::More tests => 1; ok( grep( /examples/, @INC ) ); Test-Harness-3.48/t/sample-tests/skipall0000644000175000017500000000006512166360606017271 0ustar leontleontprint < 1; my $warnings = ''; { local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; `$^X -e1`; } like( $warnings, '/^Insecure dependency/', '-t honored' ); Test-Harness-3.48/t/sample-tests/no_output0000644000175000017500000000003212166360606017660 0ustar leontleont#!/usr/bin/perl -w exit; Test-Harness-3.48/t/sample-tests/head_fail0000644000175000017500000000016512166360606017527 0ustar leontleontprint < \\ ok 2 Not a continuation line DUMMY_TEST Test-Harness-3.48/t/sample-tests/lone_not_bug0000644000175000017500000000020112166360606020274 0ustar leontleont# There was a bug where the first test would be considered a # 'lone not' failure. print < 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.48/t/source_tests/0000755000175000017500000000000014506607710016007 5ustar leontleontTest-Harness-3.48/t/source_tests/source.pl0000644000175000017500000000010612166360606017641 0ustar leontleont#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - source.pl END_TESTS Test-Harness-3.48/t/source_tests/source.t0000644000175000017500000000010513135104137017460 0ustar leontleont#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - source.t END_TESTS Test-Harness-3.48/t/source_tests/harness_directives0000644000175000017500000000026312166360606021617 0ustar leontleont#!/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.48/t/source_tests/source.tap0000644000175000017500000000002712166360606020014 0ustar leontleont1..1 ok 1 - source.tap Test-Harness-3.48/t/source_tests/harness_failure0000644000175000017500000000035312166360606021105 0ustar leontleont#!/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.48/t/source_tests/source.bat0000644000175000017500000000014712166360606020001 0ustar leontleont@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.48/t/source_tests/harness_complain0000644000175000017500000000016512166360606021261 0ustar leontleont#!/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.48/t/source_tests/harness_badtap0000644000175000017500000000016012166360606020705 0ustar leontleont#!/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.48/t/source_tests/source.sh0000755000175000017500000000005612765211622017645 0ustar leontleont#!/bin/sh echo "1..1" echo "ok 1 - source.sh" Test-Harness-3.48/t/source_tests/source_args.sh0000755000175000017500000000006612765211622020662 0ustar leontleont#!/bin/sh echo "1..1" echo "ok 1 - source_args.sh $1" Test-Harness-3.48/t/source_tests/psql.bat0000755000175000017500000000067312765211622017465 0ustar leontleont@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.48/t/source_tests/source0000644000175000017500000000022512166360606017231 0ustar leontleont#!/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.48/t/source_tests/source.10000644000175000017500000000002512166360606017366 0ustar leontleont1..1 ok 1 - source.1 Test-Harness-3.48/t/source_tests/harness0000644000175000017500000000011312166360606017370 0ustar leontleont#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - this is a test END_TESTS Test-Harness-3.48/t/source_tests/test.tap0000644000175000017500000000020313135105362017460 0ustar leontleont#!/usr/bin/perl # This looks equally like a TAP file and a Perl executable. print <<'END_TESTS'; 1..1 ok 1 - source.pl END_TESTS Test-Harness-3.48/t/scheduler.t0000644000175000017500000001252313135104130015414 0ustar leontleont#!/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.48/t/file.t0000644000175000017500000003323514424057335014400 0ustar leontleont#!/usr/bin/perl -w BEGIN { delete $ENV{HARNESS_OPTIONS}; 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.48/t/bailout.t0000755000175000017500000000617713135104143015114 0ustar leontleont#!/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.48/t/source_handler.t0000644000175000017500000003231114424057335016450 0ustar leontleont#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More tests => 82; 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 => '.t (no shebang)', meta => { is_file => 1, file => { lc_ext => '.t', dir => '', shebang => 'use strict;' } }, 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 => '#!...sh', meta => { is_file => 1, file => { lc_ext => '', dir => '', shebang => '#!/bin/sh' } }, vote => 0.3, }, { name => 'use strict; # first line not shebang', meta => { is_file => 1, file => { lc_ext => '', dir => '', shebang => 'use strict;' } }, vote => 0.25, }, { 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.48/t/compat/0000755000175000017500000000000014506607710014550 5ustar leontleontTest-Harness-3.48/t/compat/env.t0000644000175000017500000000116313135104130015507 0ustar leontleont#!/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.48/t/compat/version.t0000644000175000017500000000043013135104132016402 0ustar leontleont#!/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.48/t/compat/subclass.t0000644000175000017500000000124413135104131016537 0ustar leontleont#!/usr/bin/perl -w # Test that HARNESS_SUBCLASS env var is honoured. use strict; use warnings; use lib 't/lib'; use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 1 ) ); use Test::Harness; my $test_template = <<'END'; #!/usr/bin/perl use Test::More tests => 1; is $ENV{HARNESS_IS_SUBCLASS}, 'TAP::Harness::TestSubclass'; END my $tempfile = "_check_subclass_t.tmp"; open TEST, ">$tempfile"; print TEST $test_template; close TEST; END { unlink $tempfile; } { local $ENV{HARNESS_SUBCLASS} = 'TAP::Harness::TestSubclass'; my ( $tot, $failed ) = Test::Harness::execute_tests( tests => [$tempfile] ); is $tot->{bad}, 0; } 1; Test-Harness-3.48/t/compat/inc-propagation.t0000644000175000017500000000260713135104175020026 0ustar leontleont#!/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.48/t/compat/test-harness-compat.t0000644000175000017500000006641214215143203020634 0ustar leontleont#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Config; # 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'; my $NoTaintSupport = exists($Config{taint_support}) && !$Config{taint_support}; my @test_list = 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 ); if ($NoTaintSupport) { @test_list = grep { $_ !~ /taint/ && $_ ne 'shbang_misparse' } @test_list; } { # 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( ',', @test_list ) => { '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' => '' }, $NoTaintSupport ? () : ( "$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' => ($NoTaintSupport ? 11 : 12), 'bonus' => 1, 'files' => ($NoTaintSupport ? 24 : 27), 'good' => ($NoTaintSupport ? 13 : 15), 'max' => ($NoTaintSupport ? 72 : 76), 'ok' => ($NoTaintSupport ? 75 : 78), 'skipped' => 2, 'sub_skipped' => 2, 'tests' => ($NoTaintSupport ? 24 : 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' => { 'skip_if' => sub { $NoTaintSupport }, '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' => { 'skip_if' => sub { $NoTaintSupport }, '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' => { 'skip_if' => sub { $NoTaintSupport }, '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' => { 'skip_if' => sub { $NoTaintSupport }, '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->(); } if (($test_key eq 'inc_taint' || $test_key eq 'shbang_misparse') && $NoTaintSupport) { skip "your perl was built without taint support", 4; } 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.48/t/compat/inc_taint.t0000644000175000017500000000116213135104132016670 0ustar leontleont#!/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.48/t/compat/switches.t0000644000175000017500000000054513135104130016553 0ustar leontleont#!/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.48/t/compat/env_opts.t0000644000175000017500000000277213135104175016574 0ustar leontleont#!/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.48/t/compat/nonumbers.t0000644000175000017500000000023013135104132016723 0ustar leontleontif ( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) { print "1..0 # Skip: t/TEST needs numbers\n"; exit; } print < 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.48/t/compat/regression.t0000644000175000017500000000056113135104131017101 0ustar leontleont#!/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.48/t/proveversion.t0000644000175000017500000000147313135104175016212 0ustar leontleont#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } sub _has_TAP_Formatter_HTML { eval "use TAP::Formatter::HTML 0.10"; #https://rt.cpan.org/Ticket/Display.html?id=74364 return $@ ? 0 : 1; } use strict; use warnings; use Test::More tests => 1; use IO::c55Capture; # for util SKIP: { skip "requires TAP::Formatter::HTML 0.10", 1 unless _has_TAP_Formatter_HTML(); my $ans = util::stdout_of( sub { system( $^X, "bin/prove", "-l", "--formatter=TAP::Formatter::HTML", "--tapversion=13", "t/sample-tests/simple_yaml_missing_version13" ) and die "error $?"; } ); like( $ans, qr/li class="yml"/, "prove --tapversion=13 simple_yaml_missing_version13" ); } Test-Harness-3.48/t/iterator_factory.t0000644000175000017500000001176413135105362017034 0ustar leontleont#!/usr/bin/perl -w # # Tests for TAP::Parser::IteratorFactory & source detection ## BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More tests => 44; 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', }, { file => 'test.tap', tie => 1, }, ); 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 = $@; if( $test->{tie} ) { like( $error, qr{^There is a tie.*Both voted .* on $test->{file}}ms, "$name: votes tied" ) } else { ok( !$error, "$name: no error on make_iterator" ); diag($error) if $error; } is( $sf->_last_handler, $test->{handler}, $name ); } __END__ 0..1 ok 1 - TAP in the __DATA__ handle Test-Harness-3.48/t/proverun.t0000644000175000017500000001021513135104175015323 0ustar leontleont#!/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.48/t/nested.t0000644000175000017500000000153413135104144014725 0ustar leontleont#!/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.48/t/env_opts.t0000644000175000017500000000350313135104175015302 0ustar leontleont#!/usr/bin/perl use strict; use warnings; use Test::More tests => 16; use TAP::Harness::Env; 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 = TAP::Harness::Env->create, 'made harness'; is( $harness->color, 1, "set color correctly" ); is( $harness->jobs, 4, "set jobs correctly" ); } SKIP: { skip "requires TAP::Formatter::HTML", 4 unless _has_module('TAP::Formatter::HTML'); skip "requires TAP::Formatter::HTML 0.10 or higher", 4 unless TAP::Formatter::HTML->VERSION >= .10; local $ENV{HARNESS_OPTIONS} = 'j4:c:fTAP-Formatter-HTML'; ok my $harness = TAP::Harness::Env->create, '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 = TAP::Harness::Env->create, '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" ); } { local $ENV{HARNESS_TIMER} = 0; ok my $harness = TAP::Harness::Env->create, 'made harness'; ok !$harness->timer, 'timer set via HARNESS_TIMER'; } { local $ENV{HARNESS_TIMER} = 1; ok my $harness = TAP::Harness::Env->create, 'made harness'; ok $harness->timer, 'timer set via HARNESS_TIMER'; } Test-Harness-3.48/t/taint.t0000644000175000017500000000246613135104175014573 0ustar leontleont#!/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.48/t/perl5lib.t0000644000175000017500000000220213135104175015156 0ustar leontleont#!/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.48/t/harness.t0000644000175000017500000007211714456317457015137 0ustar leontleont#!/usr/bin/perl -w BEGIN { unshift @INC, 't/lib'; } use strict; use warnings; use Test::More; use IO::c55Capture; use Config; use POSIX; 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 => 133; # 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]]', '[[green]]', 'ok', '[[reset]]', '[[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]]', '[[green]]', 'ok', '[[reset]]', '[[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]]', '[[green]]', 'ok', '[[reset]]', 'My Nice Test Again ..', '1..1', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', '[[green]]', 'ok', '[[reset]]', '[[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'; SKIP: { skip "No SIGSEGV on $^O", 1 if $^O eq 'MSWin32' or $Config::Config{'sig_name'} !~ m/SEGV/; # some people -Dcc="somecc -fsanitize=..." or -Doptimize="-fsanitize=..." skip "ASAN doesn't passthrough SEGV", 1 if "$Config{cc} $Config{ccflags} $Config{optimize}" =~ /-fsanitize\b/; @output = (); _runtests( $harness_failures, "$sample_tests/segfault" ); my $out_str = join q<>, @output; like( $out_str, qr, 'SIGSEGV is parsed out' ); } #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.48/t/parse.t0000755000175000017500000007574014506606110014575 0ustar leontleont#!/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 42 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 42 but we don't know about versions later than 14/, '... 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.48/t/unicode.t0000644000175000017500000000736013135104142015072 0ustar leontleont#!/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.48/t/premature-bailout.t0000644000175000017500000000451113135104175017106 0ustar leontleont#!/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.48/t/streams.t0000755000175000017500000001452613135104135015131 0ustar leontleont#!/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.48/t/yamlish.t0000644000175000017500000004300514173043316015116 0ustar leontleont#!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 => 'Edge cases for hash start vs. undefined scalar 1', in => [ '---', 'one:', ' five: 5', ' two:', ' four: 4', ' three: 3', 'six: 6', '...', ], out => { one => { two => undef, three => '3', four => '4', five => '5' }, six => '6' }, }, { name => 'Edge cases for hash start vs. undefined scalar 2', in => [ '---', 'one:', ' five: 5', ' two: ~', ' four: 4', ' three: 3', 'six: 6', '...', ], out => { one => { two => undef, three => '3', four => '4', five => '5' }, six => '6' }, }, { name => 'Edge cases for hash start vs. undefined scalar 3', in => [ '---', 'two:', 'four: 4', 'three: 3', '...', ], out => { two => undef, three => '3', four => '4', }, }, { name => 'Edge cases for hash start vs. undefined scalar 4', in => [ '---', 'two:', ' four: 4', ' three: 3', '...', ], out => { two => { three => '3', four => '4' }, }, }, { name => 'Edge cases for hash start vs. undefined scalar 5', in => [ '---', 'two:', '- four: 4', '- three: 3', '...', ], out => { two => [ { four => '4' }, { three => '3' } ], }, }, { name => 'Space after colon', in => [ '---', 'spog: ', ' - 1', ' - 2', '...' ], out => { spog => [ 1, 2 ] }, }, { name => 'Original YAML::Tiny test', in => [ '---', 'invoice: 34843', 'date : 2001-01-23', 'bill-to:', ' given : Chris', ' family : Dumars', ' address:', ' lines: |', ' 458 Walkman Dr.', ' Suite #292', ' city : Royal Oak', ' state : MI', ' postal : 48046', 'product:', ' - sku : BL394D', ' quantity : 4', ' description : Basketball', ' price : 450.00', ' - sku : BL4438H', ' quantity : 1', ' description : Super Hoop', ' price : 2392.00', 'tax : 251.42', 'total: 4443.52', 'comments: >', ' Late afternoon is best.', ' Backup contact is Nancy', ' Billsmer @ 338-4338', '...', ], out => { 'bill-to' => { 'given' => 'Chris', 'address' => { 'city' => 'Royal Oak', 'postal' => '48046', 'lines' => "458 Walkman Dr.\nSuite #292\n", 'state' => 'MI' }, 'family' => 'Dumars' }, 'invoice' => '34843', 'date' => '2001-01-23', 'tax' => '251.42', 'product' => [ { 'sku' => 'BL394D', 'quantity' => '4', 'price' => '450.00', 'description' => 'Basketball' }, { 'sku' => 'BL4438H', 'quantity' => '1', 'price' => '2392.00', 'description' => 'Super Hoop' } ], 'comments' => "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", 'total' => '4443.52' } }, # Tests harvested from YAML::Tiny { in => ['...'], name => 'Regression: empty', error => qr{document\s+header\s+not\s+found} }, { in => [ '# comment', '...' ], name => 'Regression: only_comment', error => qr{document\s+header\s+not\s+found} }, { out => undef, in => [ '---', '...' ], name => 'Regression: only_header', error => qr{Premature\s+end}i, }, { out => undef, in => [ '---', '---', '...' ], name => 'Regression: two_header', error => qr{Unexpected\s+start}i, }, { out => undef, in => [ '--- ~', '...' ], name => 'Regression: one_undef' }, { out => undef, in => [ '--- ~', '...' ], name => 'Regression: one_undef2' }, { in => [ '--- ~', '---', '...' ], name => 'Regression: two_undef', error => qr{Missing\s+'[.][.][.]'}, }, { out => 'foo', in => [ '--- foo', '...' ], name => 'Regression: one_scalar', }, { out => 'foo', in => [ '--- foo', '...' ], name => 'Regression: one_scalar2', }, { in => [ '--- foo', '--- bar', '...' ], name => 'Regression: two_scalar', error => qr{Missing\s+'[.][.][.]'}, }, { out => ['foo'], in => [ '---', '- foo', '...' ], name => 'Regression: one_list1' }, { out => [ 'foo', 'bar' ], in => [ '---', '- foo', '- bar', '...' ], name => 'Regression: one_list2' }, { out => [ undef, 'bar' ], in => [ '---', '- ~', '- bar', '...' ], name => 'Regression: one_listundef' }, { out => { 'foo' => 'bar' }, in => [ '---', 'foo: bar', '...' ], name => 'Regression: one_hash1' }, { out => { 'foo' => 'bar', 'this' => undef }, in => [ '---', 'foo: bar', 'this: ~', '...' ], name => 'Regression: one_hash2' }, { out => { 'foo' => [ 'bar', undef, 'baz' ] }, in => [ '---', 'foo:', ' - bar', ' - ~', ' - baz', '...' ], name => 'Regression: array_in_hash' }, { out => { 'bar' => { 'foo' => 'bar' }, 'foo' => undef }, in => [ '---', 'foo: ~', 'bar:', ' foo: bar', '...' ], name => 'Regression: hash_in_hash' }, { out => [ { 'foo' => undef, 'this' => 'that' }, 'foo', undef, { 'foo' => 'bar', 'this' => 'that' } ], in => [ '---', '-', ' foo: ~', ' this: that', '- foo', '- ~', '-', ' foo: bar', ' this: that', '...' ], name => 'Regression: hash_in_array' }, { out => ['foo'], in => [ '---', '- \'foo\'', '...' ], name => 'Regression: single_quote1' }, { out => [' '], in => [ '---', '- \' \'', '...' ], name => 'Regression: single_spaces' }, { out => [''], in => [ '---', '- \'\'', '...' ], name => 'Regression: single_null' }, { out => ' ', in => [ '--- " "', '...' ], name => 'Regression: only_spaces' }, { out => ['first','second'], in => [ '--- ', '- first ', '- second ', '...' ], name => "Space after header for array", }, { out => {'key' => [{'value' => {'key2' => 'value2'}}]}, in => [ '--- ', 'key: ', '- value: ', ' key2: value2 ', '... ' ], name => "Space after header for hash", }, { out => [ undef, { 'foo' => 'bar', 'this' => 'that' }, 'baz' ], in => [ '---', '- ~', '- foo: bar', ' this: that', '- baz', '...' ], name => 'Regression: inline_nested_hash' }, { name => "Unprintables", # This is an ASCII centric test 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.48/t/subclass_tests/0000755000175000017500000000000014506607710016326 5ustar leontleontTest-Harness-3.48/t/subclass_tests/perl_source0000644000175000017500000000011312166360606020566 0ustar leontleont#!/usr/bin/perl print <<'END_TESTS'; 1..1 ok 1 - this is a test END_TESTS Test-Harness-3.48/t/subclass_tests/non_perl_source0000644000175000017500000000006312166360606021444 0ustar leontleont#!/bin/sh echo "1..1" echo "ok 1 - this is a test" Test-Harness-3.48/t/results.t0000644000175000017500000001727013135104175015154 0ustar leontleont#!/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.48/t/data/0000755000175000017500000000000014506607710014176 5ustar leontleontTest-Harness-3.48/t/data/catme.10000644000175000017500000000001212166360606015342 0ustar leontleont1..1 ok 1 Test-Harness-3.48/t/data/proverc0000644000175000017500000000017712166360606015606 0ustar leontleont--should be --split correctly # No comment! Can "quote things" 'using single or' "double quotes" # More stuff --this is 'OK?' Test-Harness-3.48/t/data/sample.yml0000644000175000017500000000111412166360606016177 0ustar leontleont--- invoice: 34843 date : 2001-01-23 bill-to: given : Chris family : Dumars address: lines: | 458 Walkman Dr. Suite #292 city : Royal Oak state : MI postal : 48046 product: - sku : BL394D quantity : 4 description : Basketball price : 450.00 - sku : BL4438H quantity : 1 description : Super Hoop price : 2392.00 tax : 251.42 total: 4443.52 comments: > Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338 Test-Harness-3.48/t/prove.t0000644000175000017500000012550314461521110014600 0ustar leontleont#!/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 @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', { show_count => 1, }, 'one', 'two', 'three' ] ], }, # Test all options individually # { name => 'Just archive', # args => { # argv => [qw( one two three )], # archive => 1, # }, # expect => { # archive => 1, # }, # runlog => [ # [ { archive => 1, # }, # 'one', 'two', # 'three' # ] # ], # }, { name => 'Just argv', args => { argv => [qw( one two three )], }, expect => { argv => [qw( one two three )], }, runlog => [ [ '_runtests', { show_count => 1 }, 'one', 'two', 'three' ] ], }, { name => 'Just blib', args => { argv => [qw( one two three )], blib => 1, }, expect => { blib => 1, }, runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just color', args => { argv => [qw( one two three )], color => 1, }, expect => { color => 1, }, runlog => [ [ '_runtests', { color => 1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just directives', args => { argv => [qw( one two three )], directives => 1, }, expect => { directives => 1, }, runlog => [ [ '_runtests', { directives => 1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just exec', args => { argv => [qw( one two three )], exec => 1, }, expect => { exec => 1, }, runlog => [ [ '_runtests', { exec => [1], show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just failures', args => { argv => [qw( one two three )], failures => 1, }, expect => { failures => 1, }, runlog => [ [ '_runtests', { failures => 1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just formatter', args => { argv => [qw( one two three )], formatter => 'TAP::Harness', }, expect => { formatter => 'TAP::Harness', }, runlog => [ [ '_runtests', { formatter_class => 'TAP::Harness', show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just includes', args => { argv => [qw( one two three )], includes => [qw( four five six )], }, expect => { includes => [qw( four five six )], }, runlog => [ [ '_runtests', { lib => mabs( [qw( four five six )] ), show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just lib', args => { argv => [qw( one two three )], lib => 1, }, expect => { lib => 1, }, runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just merge', args => { argv => [qw( one two three )], merge => 1, }, expect => { merge => 1, }, runlog => [ [ '_runtests', { merge => 1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just parse', args => { argv => [qw( one two three )], parse => 1, }, expect => { parse => 1, }, runlog => [ [ '_runtests', { errors => 1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just quiet', args => { argv => [qw( one two three )], quiet => 1, }, expect => { quiet => 1, }, runlog => [ [ '_runtests', { verbosity => -1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just really_quiet', args => { argv => [qw( one two three )], really_quiet => 1, }, expect => { really_quiet => 1, }, runlog => [ [ '_runtests', { verbosity => -2, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just recurse', args => { argv => [qw( one two three )], recurse => 1, }, expect => { recurse => 1, }, runlog => [ [ '_runtests', { show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just reverse', args => { argv => [qw( one two three )], backwards => 1, }, expect => { backwards => 1, }, runlog => [ [ '_runtests', { show_count => 1, }, 'three', 'two', 'one' ] ], }, { name => 'Just shuffle', args => { argv => [qw( one two three )], shuffle => 1, }, expect => { shuffle => 1, }, runlog => [ [ '_runtests', { show_count => 1, }, 'xxxone', 'xxxtwo', 'xxxthree' ] ], }, { name => 'Just taint_fail', args => { argv => [qw( one two three )], taint_fail => 1, }, expect => { taint_fail => 1, }, runlog => [ [ '_runtests', { switches => ['-T'], show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just taint_warn', args => { argv => [qw( one two three )], taint_warn => 1, }, expect => { taint_warn => 1, }, runlog => [ [ '_runtests', { switches => ['-t'], show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just verbose', args => { argv => [qw( one two three )], verbose => 1, }, expect => { verbose => 1, }, runlog => [ [ '_runtests', { verbosity => 1, show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just warnings_fail', args => { argv => [qw( one two three )], warnings_fail => 1, }, expect => { warnings_fail => 1, }, runlog => [ [ '_runtests', { switches => ['-W'], show_count => 1, }, 'one', 'two', 'three' ] ], }, { name => 'Just warnings_warn', args => { argv => [qw( one two three )], warnings_warn => 1, }, expect => { warnings_warn => 1, }, runlog => [ [ '_runtests', { switches => ['-w'], show_count => 1, }, 'one', 'two', 'three' ] ], }, # Command line parsing { name => 'Switch -v', args => { argv => [qw( one two three )], }, switches => [ '-v', $dummy_test ], expect => { verbose => 1, }, runlog => [ [ '_runtests', { verbosity => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --verbose', args => { argv => [qw( one two three )], }, switches => [ '--verbose', $dummy_test ], expect => { verbose => 1, }, runlog => [ [ '_runtests', { verbosity => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -f', args => { argv => [qw( one two three )], }, switches => [ '-f', $dummy_test ], expect => { failures => 1 }, runlog => [ [ '_runtests', { failures => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --failures', args => { argv => [qw( one two three )], }, switches => [ '--failures', $dummy_test ], expect => { failures => 1 }, runlog => [ [ '_runtests', { failures => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -l', args => { argv => [qw( one two three )], }, switches => [ '-l', $dummy_test ], expect => { lib => 1 }, runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --lib', args => { argv => [qw( one two three )], }, switches => [ '--lib', $dummy_test ], expect => { lib => 1 }, runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -b', args => { argv => [qw( one two three )], }, switches => [ '-b', $dummy_test ], expect => { blib => 1 }, runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --blib', args => { argv => [qw( one two three )], }, switches => [ '--blib', $dummy_test ], expect => { blib => 1 }, runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -s', args => { argv => [qw( one two three )], }, switches => [ '-s', $dummy_test ], expect => { shuffle => 1 }, runlog => [ [ '_runtests', { show_count => 1, }, "xxx$dummy_test" ] ], }, { name => 'Switch --shuffle', args => { argv => [qw( one two three )], }, switches => [ '--shuffle', $dummy_test ], expect => { shuffle => 1 }, runlog => [ [ '_runtests', { show_count => 1, }, "xxx$dummy_test" ] ], }, { name => 'Switch -c', args => { argv => [qw( one two three )], }, switches => [ '-c', $dummy_test ], expect => { color => 1 }, runlog => [ [ '_runtests', { color => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -r', args => { argv => [qw( one two three )], }, switches => [ '-r', $dummy_test ], expect => { recurse => 1 }, runlog => [ [ '_runtests', { show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --recurse', args => { argv => [qw( one two three )], }, switches => [ '--recurse', $dummy_test ], expect => { recurse => 1 }, runlog => [ [ '_runtests', { show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --reverse', args => { argv => [qw( one two three )], }, switches => [ '--reverse', @dummy_tests ], expect => { backwards => 1 }, runlog => [ [ '_runtests', { show_count => 1, }, reverse @dummy_tests ] ], }, { name => 'Switch -p', args => { argv => [qw( one two three )], }, switches => [ '-p', $dummy_test ], expect => { parse => 1, }, runlog => [ [ '_runtests', { errors => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --parse', args => { argv => [qw( one two three )], }, switches => [ '--parse', $dummy_test ], expect => { parse => 1, }, runlog => [ [ '_runtests', { errors => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -q', args => { argv => [qw( one two three )], }, switches => [ '-q', $dummy_test ], expect => { quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --quiet', args => { argv => [qw( one two three )], }, switches => [ '--quiet', $dummy_test ], expect => { quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -Q', args => { argv => [qw( one two three )], }, switches => [ '-Q', $dummy_test ], expect => { really_quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -2, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --QUIET', args => { argv => [qw( one two three )], }, switches => [ '--QUIET', $dummy_test ], expect => { really_quiet => 1 }, runlog => [ [ '_runtests', { verbosity => -2, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch -m', args => { argv => [qw( one two three )], }, switches => [ '-m', $dummy_test ], expect => { merge => 1 }, runlog => [ [ '_runtests', { merge => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --merge', args => { argv => [qw( one two three )], }, switches => [ '--merge', $dummy_test ], expect => { merge => 1 }, runlog => [ [ '_runtests', { merge => 1, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --directives', args => { argv => [qw( one two three )], }, switches => [ '--directives', $dummy_test ], expect => { directives => 1 }, runlog => [ [ '_runtests', { directives => 1, show_count => 1, }, $dummy_test ] ], }, # .proverc { name => 'Empty exec in .proverc', args => { argv => [qw( one two three )], }, proverc => 't/proverc/emptyexec', switches => [$dummy_test], expect => { exec => '' }, runlog => [ [ '_runtests', { exec => [], show_count => 1, }, $dummy_test ] ], }, # Executing one word (why would it be a -s though?) { name => 'Switch --exec -s', args => { argv => [qw( one two three )], }, switches => [ '--exec', '-s', $dummy_test ], expect => { exec => '-s' }, runlog => [ [ '_runtests', { exec => ['-s'], show_count => 1, }, $dummy_test ] ], }, # multi-part exec { name => 'Switch --exec "/foo/bar/perl -Ilib"', args => { argv => [qw( one two three )], }, switches => [ '--exec', '/foo/bar/perl -Ilib', $dummy_test ], expect => { exec => '/foo/bar/perl -Ilib' }, runlog => [ [ '_runtests', { exec => [qw(/foo/bar/perl -Ilib)], show_count => 1, }, $dummy_test ] ], }, # null exec (run tests as compiled binaries) { name => 'Switch --exec ""', switches => [ '--exec', '', $dummy_test ], expect => { exec => # ick, must workaround the || default bit with a sub sub { my $val = shift; defined($val) and !length($val) } }, runlog => [ [ '_runtests', { exec => [], show_count => 1, }, $dummy_test ] ], }, # Specify an oddball extension { name => 'Switch --ext=.wango', switches => ['--ext=.wango'], expect => { extensions => ['.wango'] }, runlog => [ [ '_runtests', { show_count => 1, }, ] ], }, # Handle multiple extensions { name => 'Switch --ext=.foo --ext=.bar', switches => [ '--ext=.foo', '--ext=.bar', ], expect => { extensions => [ '.foo', '.bar' ] }, runlog => [ [ '_runtests', { show_count => 1, }, ] ], }, # Source handlers { name => 'Switch --source simple', args => { argv => [qw( one two three )] }, switches => [ '--source', 'MyCustom', $dummy_test ], expect => { sources => { MyCustom => {}, }, }, runlog => [ [ '_runtests', { sources => { MyCustom => {}, }, show_count => 1, }, $dummy_test ] ], }, { name => 'Switch --sources with config', args => { argv => [qw( one two three )] }, skip => $Getopt::Long::VERSION >= 2.28 && $HAS_YAML ? 0 : 1, skip_reason => "YAML not available or Getopt::Long too old", switches => [ '--source', 'Perl', '--perl-option', 'foo=bar baz', '--perl-option', 'avg=0.278', '--source', 'MyCustom', '--source', 'File', '--file-option', 'extensions=.txt', '--file-option', 'extensions=.tmp', '--file-option', 'hash=this=that', '--file-option', 'hash=foo=bar', '--file-option', 'sep=foo\\=bar', $dummy_test ], expect => { sources => { Perl => { foo => 'bar baz', avg => 0.278 }, MyCustom => {}, File => { extensions => [ '.txt', '.tmp' ], hash => { this => 'that', foo => 'bar' }, sep => 'foo=bar', }, }, }, runlog => [ [ '_runtests', { sources => { Perl => { foo => 'bar baz', avg => 0.278 }, MyCustom => {}, File => { extensions => [ '.txt', '.tmp' ], hash => { this => 'that', foo => 'bar' }, sep => 'foo=bar', }, }, show_count => 1, }, $dummy_test ] ], }, # Plugins { name => 'Load plugin', switches => [ '-P', 'Dummy', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_plugin_load_log(); ok @loaded == 1 && $loaded[0][0] eq 'App::Prove::Plugin::Dummy', "Plugin loaded OK"; }, plan => 1, runlog => [ [ '_runtests', { show_count => 1, }, $dummy_test ] ], }, { name => 'Load plugin (args)', switches => [ '-P', 'Dummy=cracking,cheese,gromit', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_plugin_load_log(); ok @loaded == 1 && $loaded[0][0] eq 'App::Prove::Plugin::Dummy', "Plugin loaded OK"; my $args = $loaded[0][1]{args}; is_deeply $args, [ 'cracking', 'cheese', 'gromit' ], "Plugin args OK"; }, plan => 1, runlog => [ [ '_runtests', { show_count => 1, }, $dummy_test ] ], }, { name => 'Load plugin (explicit path)', switches => [ '-P', 'App::Prove::Plugin::Dummy', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_plugin_load_log(); ok @loaded == 1 && $loaded[0][0] eq 'App::Prove::Plugin::Dummy', "Plugin loaded OK"; }, plan => 1, runlog => [ [ '_runtests', { show_count => 1, }, $dummy_test ] ], }, { name => 'Load plugin (args + call load method)', switches => [ '-P', 'Dummy2=fou,du,fafa', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy2'], }, extra => sub { my @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', { show_count => 1, }, $dummy_test ] ], }, { name => 'Load module', switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ], args => { argv => [qw( one two three )], }, expect => { plugins => ['Dummy'], }, extra => sub { my @loaded = get_plugin_load_log(); ok @loaded == 1 && $loaded[0][0] eq 'App::Prove::Plugin::Dummy', "Plugin loaded OK"; }, plan => 1, runlog => [ [ '_runtests', { show_count => 1, }, $dummy_test ] ], }, # TODO # Hmm, that doesn't work... # { name => 'Switch -h', # args => { # argv => [qw( one two three )], # }, # switches => [ '-h', $dummy_test ], # expect => {}, # runlog => [ # [ '_runtests', # {}, # $dummy_test # ] # ], # }, # { name => 'Switch --help', # args => { # argv => [qw( one two three )], # }, # switches => [ '--help', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # { name => 'Switch -?', # args => { # argv => [qw( one two three )], # }, # switches => [ '-?', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch -H', # args => { # argv => [qw( one two three )], # }, # switches => [ '-H', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --man', # args => { # argv => [qw( one two three )], # }, # switches => [ '--man', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch -V', # args => { # argv => [qw( one two three )], # }, # switches => [ '-V', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --version', # args => { # argv => [qw( one two three )], # }, # switches => [ '--version', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --color!', # args => { # argv => [qw( one two three )], # }, # switches => [ '--color!', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # { name => 'Switch -I=s@', args => { argv => [qw( one two three )], }, switches => [ '-Ilib', $dummy_test ], expect => { includes => sub { my ( $val, $attr ) = @_; return 'ARRAY' eq ref $val && 1 == @$val && $val->[0] =~ /lib$/; }, }, }, # { name => 'Switch -a', # args => { # argv => [qw( one two three )], # }, # switches => [ '-a', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --archive=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--archive=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --formatter=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--formatter=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch -e', # args => { # argv => [qw( one two three )], # }, # switches => [ '-e', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, # # { name => 'Switch --harness=-s', # args => { # argv => [qw( one two three )], # }, # switches => [ '--harness=-s', $dummy_test ], # expect => {}, # runlog => [ # [ {}, # $dummy_test # ] # ], # }, ); # END SCHEDULE ######################################################################## my $extra_plan = 0; for my $test (@SCHEDULE) { my $plan = 0; $plan += $test->{plan} || 0; $plan += 2 if $test->{runlog}; $plan += 1 if $test->{switches}; $test->{_planned} = $plan + 3 + @ATTR; $extra_plan += $plan; } plan tests => @SCHEDULE * ( 3 + @ATTR ) + $extra_plan; } # END PLAN # ACTUAL TEST for my $test (@SCHEDULE) { my $name = $test->{name}; my $class = $test->{class} || 'FakeProve'; SKIP: { skip $test->{skip_reason}, $test->{_planned} if $test->{skip}; local $ENV{HARNESS_TIMER}; ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ), "$name: App::Prove created OK"; isa_ok $app, 'App::Prove'; isa_ok $app, $class; # Optionally parse command args if ( my $switches = $test->{switches} ) { if ( my $proverc = $test->{proverc} ) { $app->add_rc_file( File::Spec->catfile( split /\//, $proverc ) ); } eval { $app->process_args( '--norc', @$switches ) }; if ( my $err_pattern = $test->{parse_error} ) { like $@, $err_pattern, "$name: expected parse error"; } else { ok !$@, "$name: no parse error"; } } my $expect = $test->{expect} || {}; for my $attr ( sort @ATTR ) { my $val = $app->$attr(); my $assertion = exists $expect->{$attr} ? $expect->{$attr} : $DEFAULT_ASSERTION{$attr}; my $is_ok = undef; if ( 'CODE' eq ref $assertion ) { $is_ok = ok $assertion->( $val, $attr ), "$name: $attr has the expected value"; } elsif ( 'Regexp' eq ref $assertion ) { $is_ok = like $val, $assertion, "$name: $attr matches $assertion"; } else { $is_ok = is_deeply $val, $assertion, "$name: $attr has the expected value"; } unless ($is_ok) { diag "got $val for $attr"; } } if ( my $runlog = $test->{runlog} ) { eval { $app->run }; if ( my $err_pattern = $test->{run_error} ) { like $@, $err_pattern, "$name: expected error OK"; pass; pass for 1 .. $test->{plan}; } else { unless ( ok !$@, "$name: no error OK" ) { diag "$name: error: $@\n"; } my $gotlog = [ $app->get_log ]; if ( my $extra = $test->{extra} ) { $extra->($gotlog); } # adapt our expectations if HARNESS_PERL_SWITCHES is set push @{ $runlog->[0][1]{switches} }, shellwords( $ENV{HARNESS_PERL_SWITCHES} ) if $ENV{HARNESS_PERL_SWITCHES}; unless ( is_deeply $gotlog, $runlog, "$name: run results match" ) { use Data::Dumper; diag Dumper( { wanted => $runlog, got => $gotlog } ); } } } } # SKIP } Test-Harness-3.48/t/state_results.t0000644000175000017500000001171113135104134016341 0ustar leontleont#!/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.48/t/proverc.t0000644000175000017500000000073013135104143015117 0ustar leontleont#!/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.48/t/yamlish-output.t0000644000175000017500000000470013135104130016440 0ustar leontleont#!/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.48/t/console.t0000644000175000017500000000207313135104135015104 0ustar leontleontuse 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.48/t/glob-to-regexp.t0000644000175000017500000000173413135104137016302 0ustar leontleont#!/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.48/t/lib/0000755000175000017500000000000014506607710014033 5ustar leontleontTest-Harness-3.48/t/lib/MyResultFactory.pm0000644000175000017500000000057213135104125017476 0ustar leontleont# 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.48/t/lib/if.pm0000644000175000017500000000227213135104126014760 0ustar leontleontpackage 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.48/t/lib/MyResult.pm0000644000175000017500000000046013135104124016141 0ustar leontleont# 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.48/t/lib/Dev/0000755000175000017500000000000014506607710014551 5ustar leontleontTest-Harness-3.48/t/lib/Dev/Null.pm0000644000175000017500000000051013135104124016001 0ustar leontleont# 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.48/t/lib/MyCustom.pm0000644000175000017500000000030413135104125016133 0ustar leontleont# 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.48/t/lib/MySourceHandler.pm0000644000175000017500000000144613135104125017427 0ustar leontleont# 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.48/t/lib/NoFork.pm0000644000175000017500000000044213243375270015567 0ustar leontleontpackage 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.48/t/lib/IO/0000755000175000017500000000000014506607710014342 5ustar leontleontTest-Harness-3.48/t/lib/IO/c55Capture.pm0000644000175000017500000000441213243375354016624 0ustar leontleontpackage 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.48/t/lib/MyFileSourceHandler.pm0000644000175000017500000000127113135105362020227 0ustar leontleont# 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 1; } sub make_iterator { my ( $class, $source ) = @_; my $iter = $class->SUPER::make_iterator($source); $MAKE_ITER++; $LAST_SOURCE = $source; return $iter; } 1; Test-Harness-3.48/t/lib/MyIterator.pm0000644000175000017500000000066213135104126016462 0ustar leontleont# 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.48/t/lib/MyPerlSourceHandler.pm0000644000175000017500000000067113135104125020251 0ustar leontleont# 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.48/t/lib/MyGrammar.pm0000644000175000017500000000046213135104124016253 0ustar leontleont# 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.48/t/lib/TAP/0000755000175000017500000000000014506607710014457 5ustar leontleontTest-Harness-3.48/t/lib/TAP/Parser/0000755000175000017500000000000014506607710015713 5ustar leontleontTest-Harness-3.48/t/lib/TAP/Parser/SubclassTest.pm0000644000175000017500000000203513135104124020654 0ustar leontleont# 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.48/t/lib/TAP/Harness/0000755000175000017500000000000014506607710016062 5ustar leontleontTest-Harness-3.48/t/lib/TAP/Harness/TestSubclass.pm0000644000175000017500000000031213135104124021017 0ustar leontleontpackage 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.48/t/lib/App/0000755000175000017500000000000014506607710014553 5ustar leontleontTest-Harness-3.48/t/lib/App/Prove/0000755000175000017500000000000014506607710015646 5ustar leontleontTest-Harness-3.48/t/lib/App/Prove/Plugin/0000755000175000017500000000000014506607710017104 5ustar leontleontTest-Harness-3.48/t/lib/App/Prove/Plugin/Dummy.pm0000644000175000017500000000016414461521110020523 0ustar leontleontpackage App::Prove::Plugin::Dummy; use strict; use warnings; sub load { main::test_log_plugin_load(@_); } 1; Test-Harness-3.48/t/lib/App/Prove/Plugin/Dummy2.pm0000644000175000017500000000016514461521110020606 0ustar leontleontpackage App::Prove::Plugin::Dummy2; use strict; use warnings; sub load { main::test_log_plugin_load(@_); } 1; Test-Harness-3.48/t/lib/NOP.pm0000644000175000017500000000010113135104126015003 0ustar leontleontpackage NOP; # Do nothing much sub new { bless {}, shift } 1; Test-Harness-3.48/t/lib/EmptyParser.pm0000644000175000017500000000062213135104125016631 0ustar leontleontpackage 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.48/t/grammar.t0000644000175000017500000002715213135104175015101 0ustar leontleont#!/usr/bin/perl -w use strict; use warnings; BEGIN { unshift @INC, 't/lib'; } use Test::More tests => 94; use EmptyParser; use TAP::Parser::Grammar; use TAP::Parser::Iterator::Array; my $GRAMMAR = 'TAP::Parser::Grammar'; # Array based iterator that we can push items in to package IT; sub new { my $class = shift; return bless [], $class; } sub next { my $self = shift; return shift @$self; } sub put { my $self = shift; unshift @$self, @_; } sub handle_unicode { } package main; my $iterator = IT->new; my $parser = EmptyParser->new; can_ok $GRAMMAR, 'new'; my $grammar = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); isa_ok $grammar, $GRAMMAR, '... and the object it returns'; # Note: all methods are actually class methods. See the docs for the reason # why. We'll still use the instance because that should be forward # compatible. my @V12 = sort qw(bailout comment plan simple_test test version); my @V13 = sort ( @V12, 'pragma', 'yaml' ); can_ok $grammar, 'token_types'; ok my @types = sort( $grammar->token_types ), '... and calling it should succeed (v12)'; is_deeply \@types, \@V12, '... and return the correct token types (v12)'; $grammar->set_version(13); ok @types = sort( $grammar->token_types ), '... and calling it should succeed (v13)'; is_deeply \@types, \@V13, '... and return the correct token types (v13)'; can_ok $grammar, 'syntax_for'; can_ok $grammar, 'handler_for'; my ( %syntax_for, %handler_for ); for my $type (@types) { ok $syntax_for{$type} = $grammar->syntax_for($type), '... and calling syntax_for() with a type name should succeed'; cmp_ok ref $syntax_for{$type}, 'eq', 'Regexp', '... and it should return a regex'; ok $handler_for{$type} = $grammar->handler_for($type), '... and calling handler_for() with a type name should succeed'; cmp_ok ref $handler_for{$type}, 'eq', 'CODE', '... and it should return a code reference'; } # Test the plan. Gotta have a plan. my $plan = '1..1'; like $plan, $syntax_for{'plan'}, 'A basic plan should match its syntax'; my $method = $handler_for{'plan'}; $plan =~ $syntax_for{'plan'}; ok my $plan_token = $grammar->$method($plan), '... and the handler should return a token'; my $expected = { 'explanation' => '', 'directive' => '', 'type' => 'plan', 'tests_planned' => 1, 'raw' => '1..1', 'todo_list' => [], }; is_deeply $plan_token, $expected, '... and it should contain the correct data'; can_ok $grammar, 'tokenize'; $iterator->put($plan); ok my $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, '... and the token should contain the correct data'; # a plan with a skip directive $plan = '1..0 # SKIP why not?'; like $plan, $syntax_for{'plan'}, 'a basic plan should match its syntax'; $plan =~ $syntax_for{'plan'}; ok $plan_token = $grammar->$method($plan), '... and the handler should return a token'; $expected = { 'explanation' => 'why not?', 'directive' => 'SKIP', 'type' => 'plan', 'tests_planned' => 0, 'raw' => '1..0 # SKIP why not?', 'todo_list' => [], }; is_deeply $plan_token, $expected, '... and it should contain the correct data'; $iterator->put($plan); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, '... and the token should contain the correct data'; # implied skip $plan = '1..0'; like $plan, $syntax_for{'plan'}, 'A plan with an implied "skip all" should match its syntax'; $plan =~ $syntax_for{'plan'}; ok $plan_token = $grammar->$method($plan), '... and the handler should return a token'; $expected = { 'explanation' => '', 'directive' => 'SKIP', 'type' => 'plan', 'tests_planned' => 0, 'raw' => '1..0', 'todo_list' => [], }; is_deeply $plan_token, $expected, '... and it should contain the correct data'; $iterator->put($plan); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, '... and the token should contain the correct data'; # bad plan $plan = '1..0 # TODO 3,4,5'; # old syntax. No longer supported unlike $plan, $syntax_for{'plan'}, 'Bad plans should not match the plan syntax'; # Bail out! my $bailout = 'Bail out!'; like $bailout, $syntax_for{'bailout'}, 'Bail out! should match a bailout syntax'; $iterator->put($bailout); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'bailout' => '', 'type' => 'bailout', 'raw' => 'Bail out!' }; is_deeply $token, $expected, '... and the token should contain the correct data'; $bailout = 'Bail out! some explanation'; like $bailout, $syntax_for{'bailout'}, 'Bail out! should match a bailout syntax'; $iterator->put($bailout); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'bailout' => 'some explanation', 'type' => 'bailout', 'raw' => 'Bail out! some explanation' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # test comment my $comment = '# this is a comment'; like $comment, $syntax_for{'comment'}, 'Comments should match the comment syntax'; $iterator->put($comment); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'comment' => 'this is a comment', 'type' => 'comment', 'raw' => '# this is a comment' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # test tests :/ my $test = 'ok 1 this is a test'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; $iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'ok' => 'ok', 'explanation' => '', 'type' => 'test', 'directive' => '', 'description' => 'this is a test', 'test_num' => '1', 'raw' => 'ok 1 this is a test' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # TODO tests $test = 'not ok 2 this is a test # TODO whee!'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; $iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'ok' => 'not ok', 'explanation' => 'whee!', 'type' => 'test', 'directive' => 'TODO', 'description' => 'this is a test', 'test_num' => '2', 'raw' => 'not ok 2 this is a test # TODO whee!' }; is_deeply $token, $expected, '... and the TODO should be parsed'; # false TODO tests # escaping that hash mark ('#') means this should *not* be a TODO test $test = 'ok 22 this is a test \# TODO whee!'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; $iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'ok' => 'ok', 'explanation' => '', 'type' => 'test', 'directive' => '', 'description' => 'this is a test \# TODO whee!', 'test_num' => '22', 'raw' => 'ok 22 this is a test \# TODO whee!' }; is_deeply $token, $expected, '... and the token should contain the correct data'; # pragmas my $pragma = 'pragma +strict'; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; $iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'type' => 'pragma', 'raw' => $pragma, 'pragmas' => ['+strict'], }; is_deeply $token, $expected, '... and the token should contain the correct data'; $pragma = 'pragma +strict,-foo'; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; $iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'type' => 'pragma', 'raw' => $pragma, 'pragmas' => [ '+strict', '-foo' ], }; is_deeply $token, $expected, '... and the token should contain the correct data'; $pragma = 'pragma +strict , -foo '; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; $iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { 'type' => 'pragma', 'raw' => $pragma, 'pragmas' => [ '+strict', '-foo' ], }; is_deeply $token, $expected, '... and the token should contain the correct data'; # coverage tests # set_version { my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $grammar->set_version('no_such_version'); }; unless ( is @die, 1, 'set_version with bad version' ) { diag " >>> $_ <<<\n" for @die; } like pop @die, qr/^Unsupported syntax version: no_such_version at /, '... and got expected message'; } # tokenize { my $iterator = IT->new; my $parser = EmptyParser->new; my $grammar = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); my $plan = ''; $iterator->put($plan); my $result = $grammar->tokenize(); isa_ok $result, 'TAP::Parser::Result::Unknown'; } # _make_plan_token { my $parser = EmptyParser->new; my $grammar = $GRAMMAR->new( { parser => $parser } ); my $plan = '1..1 # SKIP with explanation'; # trigger warning in _make_plan_token my $method = $handler_for{'plan'}; $plan =~ $syntax_for{'plan'}; # perform regex to populate $1, $2 my @warn; eval { local $SIG{__WARN__} = sub { push @warn, @_ }; $grammar->$method($plan); }; is @warn, 1, 'catch warning on inconsistent plan'; like pop @warn, qr/^Specified SKIP directive in plan but more than 0 tests [(]1\.\.1 # SKIP with explanation[)]/, '... and its what we expect'; } # _make_yaml_token SKIP: { skip 'Test is broken and needs repairs', 2; my $iterator = IT->new; my $parser = EmptyParser->new; my $grammar = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); $grammar->set_version(13); # now this is badly formed YAML that is missing the # leader padding - this is done for coverage testing # the $reader code sub in _make_yaml_token, that is # passed as the yaml consumer to T::P::YAMLish::Reader. # because it isnt valid yaml, the yaml document is # not done, and the _peek in the YAMLish::Reader # code doesnt find the terminating '...' pattern. # but we dont care as this is coverage testing, so # if thats what we have to do to exercise that code, # so be it. my $yaml = [ ' --- ', '- 2', ' ... ', ]; sub iter { my $ar = shift; return sub { return shift @$ar; }; } my $iter = iter($yaml); while ( my $line = $iter->() ) { $iterator->put($line); } # pad == ' ', marker == '--- ' # length $pad == 3 # strip == pad my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; $grammar->tokenize; }; is @die, 1, 'checking badly formed yaml for coverage testing'; like pop @die, qr/^Missing '[.][.][.]' at end of YAMLish/, '...and it died like we expect'; } { # coverage testing for TAP::Parser::Iterator::Array my $source = [qw( a b c )]; my $aiter = TAP::Parser::Iterator::Array->new($source); my $first = $aiter->next_raw; is $first, 'a', 'access raw iterator'; is $aiter->exit, undef, '... and note we didnt exhaust the source'; } Test-Harness-3.48/t/object.t0000644000175000017500000000140413135104133014703 0ustar leontleont#!/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.48/t/proverc/0000755000175000017500000000000014506607710014745 5ustar leontleontTest-Harness-3.48/t/proverc/emptyexec0000644000175000017500000000001312166360606016665 0ustar leontleont--exec '' Test-Harness-3.48/t/testargs.t0000644000175000017500000001171013135104135015274 0ustar leontleont#!/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.48/t/state.t0000644000175000017500000001731413135104143014565 0ustar leontleont#!/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.48/t/yamlish-writer.t0000644000175000017500000001625513135104141016426 0ustar leontleont#!/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.48/t/multiplexer.t0000644000175000017500000001104113135104175016013 0ustar leontleont#!/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.48/t/process.t0000644000175000017500000000176713135104175015135 0ustar leontleont#!/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.48/t/regression.t0000644000175000017500000034457514215143203015641 0ustar leontleont#!/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 $NoTaintSupport = exists($Config{taint_support}) && !$Config{taint_support}; 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, }, space_after_plan_v13 => { 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, }, 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, skip_if => sub {$NoTaintSupport}, 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.48/t/base.t0000644000175000017500000001126713135104175014365 0ustar leontleont#!/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.48/t/parser-config.t0000644000175000017500000000133313135104175016203 0ustar leontleont#!/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.48/t/parser-subclass.t0000644000175000017500000000431713135104175016562 0ustar leontleont#!/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.48/t/spool.t0000644000175000017500000000617013135104143014577 0ustar leontleont#!/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.48/t/harness-bailout.t0000644000175000017500000001034514363574611016561 0ustar leontleontpackage My::Aggregator; use strict; use warnings; sub new { my ($class) = @_; my $self = { results => {} }; return bless( $self, $class ); } sub start {} sub stop {} sub add { my ($self, $description, $parser) = @_; die "Test '$description' run twice" if exists $self->{results}{$description}; $self->{results}{$description} = $parser; } 1; package My::Session; use strict; use warnings; sub new { my ($class, %args) = @_; my $self = { %args }; return bless( $self, $class ); } sub result { my ($self, $result) = @_; return $self->{result} = $result || $self->{result}; } sub close_test { shift->{closed} = 1; } 1; package My::Formatter; use strict; use warnings; sub new { my ($class, $args) = @_; my $self = { %$args }; return bless( $self, $class ); } sub summary { my ($self, $aggregator, $interrupted) = @_; return sprintf( "My %sinterrupted formatter summary for %s", $interrupted ? '' : 'un', ref $aggregator ); } sub verbosity { 0; } sub prepare {}; sub open_test { my ($self, $test_name, $parser) = @_; return My::Session->new( name => $test_name, parser => $parser ); }; 1; package My::Multiplexer; use strict; use warnings; sub new { my ($class) = @_; my $self = { parsers => [] }; return bless( $self, $class ); } sub add { my ( $self, $parser, $stash ) = @_; push @{ $self->{parsers} }, [ $parser, $stash ]; } sub parsers { return scalar @{ shift->{parsers} }; } sub next { my ($self) = @_; return unless $self->parsers; my ($parser, $stash) = @{ $self->{parsers}->[0] }; my $result = $parser->next; shift @{ $self->{parsers} } unless $result; return ( $parser, $stash, $result ); } 1; package My::Result; use strict; use warnings; sub new { my ($class, %args) = @_; my $self = { %args }; return bless( $self, $class ); } sub is_bailout { return ( (shift->{source} || '') =~ '^bailout' ); } sub explanation { return shift->{source}; } 1; package My::Parser; use strict; use warnings; sub new { my ($class, $args) = @_; my $self = { %$args, nexted => 0 }; return bless( $self, $class ); } sub next { my ($self) = @_; return if $self->{nexted}; $self->{nexted} = 1; return My::Result->new( source => $self->{source} ); } sub delete_spool {} sub get_time { 0 } sub get_times { 0 } sub start_time {} sub start_times {} 1; package My::Job; use strict; use warnings; our @finished_jobs; sub new { my ($class, %args) = @_; my $self = { %args }; return bless( $self, $class ); } sub description { shift->{description} }; sub filename { shift->{filename} }; sub is_spinner {}; sub as_array_ref { return [ shift->description ] }; sub finish { push @finished_jobs, shift->filename; } 1; package My::Scheduler; use strict; use warnings; sub new { my ($class, %args) = @_; my @jobs = map { My::Job->new( filename => $_->[0], description => $_->[1] ) } @{ delete( $args{tests} ) || [] }; my $self = { %args, jobs => [ @jobs ] }; return bless( $self, $class ); } sub get_all { @{ shift->{jobs} || [] }; } sub get_job { shift( @{ shift->{jobs} } ); } 1; package main; use strict; use warnings; use Test::More tests => 4; use TAP::Harness; sub create_harness { my (%arg) = @_; return TAP::Harness->new({ aggregator_class => 'My::Aggregator', formatter_class => 'My::Formatter', multiplexer_class => 'My::Multiplexer', parser_class => 'My::Parser', scheduler_class => 'My::Scheduler', jobs => $arg{jobs} || 1, }); } my @after_test_callbacks; my $harness = create_harness( jobs => 1 ); $harness->callback( after_test => sub { push @after_test_callbacks, $_[0] } ); eval { $harness->runtests( qw( no-bailout bailout not-executed ) ); }; my $err = $@; like $err, qr/FAILED--Further testing stopped: bailout/; $harness = create_harness( jobs => 2 ); $harness->callback( after_test => sub { push @after_test_callbacks, $_[0] } ); eval { $harness->runtests( qw( no-bailout-parallel bailout-parallel not-executed-parallel ) ); }; $err = $@; like $err, qr/FAILED--Further testing stopped: bailout/; is_deeply( [ @after_test_callbacks ], [ [ 'no-bailout' ], [ 'bailout' ], [ 'no-bailout-parallel' ], [ 'bailout-parallel' ], ], 'After test callbacks called OK' ); is_deeply( [ @My::Job::finished_jobs ], [ 'no-bailout', 'bailout', 'no-bailout-parallel', 'bailout-parallel', ], 'Jobs finished OK' ); Test-Harness-3.48/META.json0000644000175000017500000000241714506607710014447 0ustar leontleont{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "keywords" : [ "TAP", "test", "harness", "prove" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Test-Harness", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "recommends" : { "Pod::Usage" : "1.12" }, "requires" : {} } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness" }, "homepage" : "http://testanything.org/", "repository" : { "url" : "http://github.com/Perl-Toolchain-Gang/Test-Harness/tree/master" } }, "version" : "3.48", "x_serialization_backend" : "JSON::PP version 4.16" } Test-Harness-3.48/MANIFEST0000644000175000017500000001243514212443244014152 0ustar leontleontbin/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 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.json META.yml perlcriticrc README t/000-load.t t/aggregator.t t/bailout.t t/base.t t/callbacks.t t/compat/env.t t/compat/env_opts.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/env_opts.t 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/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/proverc.t t/proverc/emptyexec t/proverun.t t/proveversion.t t/regression.t t/results.t t/rulesfile.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/space_after_plan_v13 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/source_tests/test.tap 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 Test-Harness-3.48/MANIFEST.CUMMULATIVE0000644000175000017500000001665212166360606015757 0ustar leontleont.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.48/lib/0000755000175000017500000000000014506607710013570 5ustar leontleontTest-Harness-3.48/lib/TAP/0000755000175000017500000000000014506607710014214 5ustar leontleontTest-Harness-3.48/lib/TAP/Object.pm0000644000175000017500000000521014506605636015763 0ustar leontleontpackage TAP::Object; use strict; use warnings; =head1 NAME TAP::Object - Base class that provides common functionality to all C modules =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =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.48/lib/TAP/Parser/0000755000175000017500000000000014506607710015450 5ustar leontleontTest-Harness-3.48/lib/TAP/Parser/Result/0000755000175000017500000000000014506607710016726 5ustar leontleontTest-Harness-3.48/lib/TAP/Parser/Result/Unknown.pm0000644000175000017500000000133614506605636020733 0ustar leontleontpackage TAP::Parser::Result::Unknown; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if the parser does not recognize the token line. For example: 1..5 VERSION 7 ok 1 - woo hooo! ... woo hooo! is cool! In the above "TAP", the second and fourth lines will generate "Unknown" tokens. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut 1; Test-Harness-3.48/lib/TAP/Parser/Result/Comment.pm0000644000175000017500000000173214506605636020676 0ustar leontleontpackage TAP::Parser::Result::Comment; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Comment - Comment result token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a comment line is encountered. 1..1 ok 1 - woo hooo! # this is a comment =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C Note that this method merely returns the comment preceded by a '# '. =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_comment ) { my $comment = $result->comment; print "I have something to say: $comment"; } =cut sub comment { shift->{comment} } sub as_string { shift->{raw} } 1; Test-Harness-3.48/lib/TAP/Parser/Result/Plan.pm0000644000175000017500000000400014506605636020155 0ustar leontleontpackage TAP::Parser::Result::Plan; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Plan - Plan result token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a plan line is encountered. 1..1 ok 1 - woo hooo! C<1..1> is the plan. Gotta have a plan. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_plan ) { print $result->plan; } This is merely a synonym for C. =cut sub plan { '1..' . shift->{tests_planned} } ############################################################################## =head3 C my $planned = $result->tests_planned; Returns the number of tests planned. For example, a plan of C<1..17> will cause this method to return '17'. =cut sub tests_planned { shift->{tests_planned} } ############################################################################## =head3 C my $directive = $plan->directive; If a SKIP directive is included with the plan, this method will return it. 1..0 # SKIP: why bother? =cut sub directive { shift->{directive} } ############################################################################## =head3 C if ( $result->has_skip ) { ... } Returns a boolean value indicating whether or not this test has a SKIP directive. =head3 C my $explanation = $plan->explanation; If a SKIP directive was included with the plan, this method will return the explanation, if any. =cut sub explanation { shift->{explanation} } =head3 C my $todo = $result->todo_list; for ( @$todo ) { ... } =cut sub todo_list { shift->{todo_list} } 1; Test-Harness-3.48/lib/TAP/Parser/Result/Version.pm0000644000175000017500000000166214506605636020723 0ustar leontleontpackage TAP::Parser::Result::Version; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a version line is encountered. TAP version 13 ok 1 not ok 2 The first version of TAP to include an explicit version number is 13. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_version ) { print $result->version; } This is merely a synonym for C. =cut sub version { shift->{version} } 1; Test-Harness-3.48/lib/TAP/Parser/Result/Pragma.pm0000644000175000017500000000166214506605636020505 0ustar leontleontpackage TAP::Parser::Result::Pragma; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a pragma is encountered. TAP version 13 pragma +strict, -foo Pragmas are only supported from TAP version 13 onwards. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_pragma ) { @pragmas = $result->pragmas; } =cut sub pragmas { my @pragmas = @{ shift->{pragmas} }; return wantarray ? @pragmas : \@pragmas; } 1; Test-Harness-3.48/lib/TAP/Parser/Result/Bailout.pm0000644000175000017500000000217414506605636020674 0ustar leontleontpackage TAP::Parser::Result::Bailout; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a bail out line is encountered. 1..5 ok 1 - woo hooo! Bail out! Well, so much for "woo hooo!" =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_bailout ) { my $explanation = $result->explanation; print "We bailed out because ($explanation)"; } If, and only if, a token is a bailout token, you can get an "explanation" via this method. The explanation is the text after the mystical "Bail out!" words which appear in the tap output. =cut sub explanation { shift->{bailout} } sub as_string { shift->{bailout} } 1; Test-Harness-3.48/lib/TAP/Parser/Result/YAML.pm0000644000175000017500000000156014506605636020035 0ustar leontleontpackage TAP::Parser::Result::YAML; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::YAML - YAML result token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a YAML block is encountered. 1..1 ok 1 - woo hooo! C<1..1> is the plan. Gotta have a plan. =head1 OVERRIDDEN METHODS Mainly listed here to shut up the pitiful screams of the pod coverage tests. They keep me awake at night. =over 4 =item * C =item * C =back =cut ############################################################################## =head2 Instance Methods =head3 C if ( $result->is_yaml ) { print $result->data; } Return the parsed YAML data for this result =cut sub data { shift->{data} } 1; Test-Harness-3.48/lib/TAP/Parser/Result/Test.pm0000644000175000017500000001367614506605636020225 0ustar leontleontpackage TAP::Parser::Result::Test; use strict; use warnings; use base 'TAP::Parser::Result'; =head1 NAME TAP::Parser::Result::Test - Test result token. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 DESCRIPTION This is a subclass of L. A token of this class will be returned if a test line is encountered. 1..1 ok 1 - woo hooo! =head1 OVERRIDDEN METHODS This class is the workhorse of the L system. Most TAP lines will be test lines and if C<< $result->is_test >>, then you have a bunch of methods at your disposal. =head2 Instance Methods =cut ############################################################################## =head3 C my $ok = $result->ok; Returns the literal text of the C or C status. =cut sub ok { shift->{ok} } ############################################################################## =head3 C my $test_number = $result->number; Returns the number of the test, even if the original TAP output did not supply that number. =cut sub number { shift->{test_num} } sub _number { my ( $self, $number ) = @_; $self->{test_num} = $number; } ############################################################################## =head3 C my $description = $result->description; Returns the description of the test, if any. This is the portion after the test number but before the directive. =cut sub description { shift->{description} } ############################################################################## =head3 C my $directive = $result->directive; Returns either C or C if either directive was present for a test line. =cut sub directive { shift->{directive} } ############################################################################## =head3 C my $explanation = $result->explanation; If a test had either a C or C directive, this method will return the accompanying explanation, if present. not ok 17 - 'Pigs can fly' # TODO not enough acid For the above line, the explanation is I. =cut sub explanation { shift->{explanation} } ############################################################################## =head3 C if ( $result->is_ok ) { ... } Returns a boolean value indicating whether or not the test passed. Remember that for TODO tests, the test always passes. If the test is unplanned, this method will always return false. See C. =cut sub is_ok { my $self = shift; return if $self->is_unplanned; # TODO directives reverse the sense of a test. return $self->has_todo ? 1 : $self->ok !~ /not/; } ############################################################################## =head3 C if ( $result->is_actual_ok ) { ... } Returns a boolean value indicating whether or not the test passed, regardless of its TODO status. =cut sub is_actual_ok { my $self = shift; return $self->{ok} !~ /not/; } ############################################################################## =head3 C Deprecated. Please use C instead. =cut sub actual_passed { warn 'actual_passed() is deprecated. Please use "is_actual_ok()"'; goto &is_actual_ok; } ############################################################################## =head3 C if ( $test->todo_passed ) { # test unexpectedly succeeded } If this is a TODO test and an 'ok' line, this method returns true. Otherwise, it will always return false (regardless of passing status on non-todo tests). This is used to track which tests unexpectedly succeeded. =cut sub todo_passed { my $self = shift; return $self->has_todo && $self->is_actual_ok; } ############################################################################## =head3 C # deprecated in favor of 'todo_passed'. This method was horribly misnamed. This was a badly misnamed method. It indicates which TODO tests unexpectedly succeeded. Will now issue a warning and call C. =cut sub todo_failed { warn 'todo_failed() is deprecated. Please use "todo_passed()"'; goto &todo_passed; } ############################################################################## =head3 C if ( $result->has_skip ) { ... } Returns a boolean value indicating whether or not this test has a SKIP directive. =head3 C if ( $result->has_todo ) { ... } Returns a boolean value indicating whether or not this test has a TODO directive. =head3 C print $result->as_string; This method prints the test as a string. It will probably be similar, but not necessarily identical, to the original test line. Directives are capitalized, some whitespace may be trimmed and a test number will be added if it was not present in the original line. If you need the original text of the test line, use the C method. =cut sub as_string { my $self = shift; my $string = $self->ok . " " . $self->number; if ( my $description = $self->description ) { $string .= " $description"; } if ( my $directive = $self->directive ) { my $explanation = $self->explanation; $string .= " # $directive $explanation"; } return $string; } ############################################################################## =head3 C if ( $test->is_unplanned ) { ... } $test->is_unplanned(1); If a test number is greater than the number of planned tests, this method will return true. Unplanned tests will I return false for C, regardless of whether or not the test C. Note that if tests have a trailing plan, it is not possible to set this property for unplanned tests as we do not know it's unplanned until the plan is reached: print <<'END'; ok 1 ok 2 1..1 END =cut sub is_unplanned { my $self = shift; return ( $self->{unplanned} || '' ) unless @_; $self->{unplanned} = !!shift; return $self; } 1; Test-Harness-3.48/lib/TAP/Parser/Result.pm0000644000175000017500000001400114506605636017265 0ustar leontleontpackage TAP::Parser::Result; use strict; use warnings; use base 'TAP::Object'; BEGIN { # make is_* methods my @attrs = qw( plan pragma test comment bailout version unknown yaml ); no strict 'refs'; for my $token (@attrs) { my $method = "is_$token"; *$method = sub { return $token eq shift->type }; } } ############################################################################## =head1 NAME TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS # abstract class - not meant to be used directly # see TAP::Parser::ResultFactory for preferred usage # directly: use TAP::Parser::Result; my $token = {...}; my $result = TAP::Parser::Result->new( $token ); =head2 DESCRIPTION This is a simple base class used by L to store objects that represent the current bit of test output data from TAP (usually a single line). Unless you're subclassing, you probably won't need to use this module directly. =head2 METHODS =head3 C # see TAP::Parser::ResultFactory for preferred usage # to use directly: my $result = TAP::Parser::Result->new($token); Returns an instance the appropriate class for the test token passed in. =cut # new() implementation provided by TAP::Object sub _initialize { my ( $self, $token ) = @_; if ($token) { # assign to a hash slice to make a shallow copy of the token. # I guess we could assign to the hash as (by default) there are not # contents, but that seems less helpful if someone wants to subclass us @{$self}{ keys %$token } = values %$token; } return $self; } ############################################################################## =head2 Boolean methods The following methods all return a boolean value and are to be overridden in the appropriate subclass. =over 4 =item * C Indicates whether or not this is the test plan line. 1..3 =item * C Indicates whether or not this is a pragma line. pragma +strict =item * C Indicates whether or not this is a test line. ok 1 Is OK! =item * C Indicates whether or not this is a comment. # this is a comment =item * C Indicates whether or not this is bailout line. Bail out! We're out of dilithium crystals. =item * C Indicates whether or not this is a TAP version line. TAP version 4 =item * C Indicates whether or not the current line could be parsed. ... this line is junk ... =item * C Indicates whether or not this is a YAML chunk. =back =cut ############################################################################## =head3 C print $result->raw; Returns the original line of text which was parsed. =cut sub raw { shift->{raw} } ############################################################################## =head3 C my $type = $result->type; Returns the "type" of a token, such as C or C. =cut sub type { shift->{type} } ############################################################################## =head3 C print $result->as_string; Prints a string representation of the token. This might not be the exact output, however. Tests will have test numbers added if not present, TODO and SKIP directives will be capitalized and, in general, things will be cleaned up. If you need the original text for the token, see the C method. =cut sub as_string { shift->{raw} } ############################################################################## =head3 C if ( $result->is_ok ) { ... } Reports whether or not a given result has passed. Anything which is B a test result returns true. This is merely provided as a convenient shortcut. =cut sub is_ok {1} ############################################################################## =head3 C Deprecated. Please use C instead. =cut sub passed { warn 'passed() is deprecated. Please use "is_ok()"'; shift->is_ok; } ############################################################################## =head3 C if ( $result->has_directive ) { ... } Indicates whether or not the given result has a TODO or SKIP directive. =cut sub has_directive { my $self = shift; return ( $self->has_todo || $self->has_skip ); } ############################################################################## =head3 C if ( $result->has_todo ) { ... } Indicates whether or not the given result has a TODO directive. =cut sub has_todo { 'TODO' eq ( shift->{directive} || '' ) } ############################################################################## =head3 C if ( $result->has_skip ) { ... } Indicates whether or not the given result has a SKIP directive. =cut sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) } =head3 C Set the directive associated with this token. Used internally to fake TODO tests. =cut sub set_directive { my ( $self, $dir ) = @_; $self->{directive} = $dir; } 1; =head1 SUBCLASSING Please see L for a subclassing overview. Remember: if you want your subclass to be automatically used by the parser, you'll have to register it with L. If you're creating a completely new result I, you'll probably need to subclass L too, or else it'll never get used. =head2 Example package MyResult; use strict; use base 'TAP::Parser::Result'; # register with the factory: TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); sub as_string { 'My results all look the same' } =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =cut Test-Harness-3.48/lib/TAP/Parser/YAMLish/0000755000175000017500000000000014506607710016716 5ustar leontleontTest-Harness-3.48/lib/TAP/Parser/YAMLish/Writer.pm0000644000175000017500000001271714506605636020545 0ustar leontleontpackage TAP::Parser::YAMLish::Writer; use strict; use warnings; use base 'TAP::Object'; our $VERSION = '3.48'; # No EBCDIC support on early perls *from_native = (ord "A" == 65 || $] < 5.008) ? sub { return shift } : sub { utf8::native_to_unicode(shift) }; my $ESCAPE_CHAR = qr{ [ [:cntrl:] \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; my @UNPRINTABLE; $UNPRINTABLE[$_] = sprintf("x%02x", from_native($_)) for 0 .. ord(" ") - 1; $UNPRINTABLE[ord "\0"] = 'z'; $UNPRINTABLE[ord "\a"] = 'a'; $UNPRINTABLE[ord "\t"] = 't'; $UNPRINTABLE[ord "\n"] = 'n'; $UNPRINTABLE[ord "\cK"] = 'v'; $UNPRINTABLE[ord "\f"] = 'f'; $UNPRINTABLE[ord "\r"] = 'r'; $UNPRINTABLE[ord "\e"] = 'e'; # new() implementation supplied by TAP::Object sub write { my $self = shift; die "Need something to write" unless @_; my $obj = shift; my $out = shift || \*STDOUT; die "Need a reference to something I can write to" unless ref $out; $self->{writer} = $self->_make_writer($out); $self->_write_obj( '---', $obj ); $self->_put('...'); delete $self->{writer}; } sub _make_writer { my $self = shift; my $out = shift; my $ref = ref $out; if ( 'CODE' eq $ref ) { return $out; } elsif ( 'ARRAY' eq $ref ) { return sub { push @$out, shift }; } elsif ( 'SCALAR' eq $ref ) { return sub { $$out .= shift() . "\n" }; } elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) { return sub { print $out shift(), "\n" }; } die "Can't write to $out"; } sub _put { my $self = shift; $self->{writer}->( join '', @_ ); } sub _enc_scalar { my $self = shift; my $val = shift; my $rule = shift; return '~' unless defined $val; if ( $val =~ /$rule/ ) { $val =~ s/\\/\\\\/g; $val =~ s/"/\\"/g; $val =~ s/ ( [[:cntrl:]] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex; return qq{"$val"}; } if ( length($val) == 0 or $val =~ /\s/ ) { $val =~ s/'/''/; return "'$val'"; } return $val; } sub _write_obj { my $self = shift; my $prefix = shift; my $obj = shift; my $indent = shift || 0; if ( my $ref = ref $obj ) { my $pad = ' ' x $indent; if ( 'HASH' eq $ref ) { if ( keys %$obj ) { $self->_put($prefix); for my $key ( sort keys %$obj ) { my $value = $obj->{$key}; $self->_write_obj( $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':', $value, $indent + 1 ); } } else { $self->_put( $prefix, ' {}' ); } } elsif ( 'ARRAY' eq $ref ) { if (@$obj) { $self->_put($prefix); for my $value (@$obj) { $self->_write_obj( $pad . '-', $value, $indent + 1 ); } } else { $self->_put( $prefix, ' []' ); } } else { die "Don't know how to encode $ref"; } } else { $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) ); } } 1; __END__ =pod =head1 NAME TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION Version 3.48 =head1 SYNOPSIS use TAP::Parser::YAMLish::Writer; my $data = { one => 1, two => 2, three => [ 1, 2, 3 ], }; my $yw = TAP::Parser::YAMLish::Writer->new; # Write to an array... $yw->write( $data, \@some_array ); # ...an open file handle... $yw->write( $data, $some_file_handle ); # ...a string ... $yw->write( $data, \$some_string ); # ...or a closure $yw->write( $data, sub { my $line = shift; print "$line\n"; } ); =head1 DESCRIPTION Encodes a scalar, hash reference or array reference as YAMLish. =head1 METHODS =head2 Class Methods =head3 C my $writer = TAP::Parser::YAMLish::Writer->new; The constructor C creates and returns an empty C object. =head2 Instance Methods =head3 C $writer->write($obj, $output ); Encode a scalar, hash reference or array reference as YAML. my $writer = sub { my $line = shift; print SOMEFILE "$line\n"; }; my $data = { one => 1, two => 2, three => [ 1, 2, 3 ], }; my $yw = TAP::Parser::YAMLish::Writer->new; $yw->write( $data, $writer ); The C< $output > argument may be: =over =item * a reference to a scalar to append YAML to =item * the handle of an open file =item * a reference to an array into which YAML will be pushed =item * a code reference =back If you supply a code reference the subroutine will be called once for each line of output with the line as its only argument. Passed lines will have no trailing newline. =head1 AUTHOR Andy Armstrong, =head1 SEE ALSO L, L, L, L, L, L =head1 COPYRIGHT Copyright 2007-2011 Andy Armstrong. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Test-Harness-3.48/lib/TAP/Parser/YAMLish/Reader.pm0000644000175000017500000002011214506605636020457 0ustar leontleontpackage TAP::Parser::YAMLish::Reader; use strict; use warnings; use base 'TAP::Object'; our $VERSION = '3.48'; # No EBCDIC support on early perls *to_native = (ord "A" == 65 || $] < 5.008) ? sub { return shift } : sub { utf8::unicode_to_native(shift) }; # TODO: # Handle blessed object syntax # Printable characters for escapes my %UNESCAPES = ( z => "\x00", a => "\a", t => "\t", n => "\n", v => "\cK", f => "\f", r => "\r", e => "\e", '\\' => '\\', ); my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x; my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x; my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x; my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x; my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x; my $IS_ARRAY_LINE = qr{ ^ - \s* ($QQ_STRING|\S+) }x; # new() implementation supplied by TAP::Object sub read { my $self = shift; my $obj = shift; die "Must have a code reference to read input from" unless ref $obj eq 'CODE'; $self->{reader} = $obj; $self->{capture} = []; # Prime the reader $self->_next; return unless $self->{next}; my $doc = $self->_read; # The terminator is mandatory otherwise we'd consume a line from the # iterator that doesn't belong to us. If we want to remove this # restriction we'll have to implement look-ahead in the iterators. # Which might not be a bad idea. my $dots = $self->_peek; die "Missing '...' at end of YAMLish" unless defined $dots and $dots =~ $IS_END_YAML; delete $self->{reader}; delete $self->{next}; return $doc; } sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" } sub _peek { my $self = shift; return $self->{next} unless wantarray; my $line = $self->{next}; $line =~ /^ (\s*) (.*) $ /x; return ( $2, length $1 ); } sub _next { my $self = shift; die "_next called with no reader" unless $self->{reader}; my $line = $self->{reader}->(); $self->{next} = $line; push @{ $self->{capture} }, $line; } sub _read { my $self = shift; my $line = $self->_peek; # Do we have a document header? if ( $line =~ /^ --- (?: \s* (.+?)? \s* )? $/x ) { $self->_next; return $self->_read_scalar($1) if defined $1; # Inline? my ( $next, $indent ) = $self->_peek; if ( $next =~ /^ - /x ) { return $self->_read_array($indent); } elsif ( $next =~ $IS_HASH_KEY ) { return $self->_read_hash( $next, $indent ); } elsif ( $next =~ $IS_END_YAML ) { die "Premature end of YAMLish"; } else { die "Unsupported YAMLish syntax: '$next'"; } } else { die "YAMLish document header not found"; } } # Parse a double quoted string sub _read_qq { my $self = shift; my $str = shift; unless ( $str =~ s/^ " (.*?) " $/$1/x ) { die "Internal: not a quoted string"; } $str =~ s/\\"/"/gx; $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) / (length($1) > 1) ? pack("H2", to_native($2)) : $UNESCAPES{$1} /gex; return $str; } # Parse a scalar string to the actual scalar sub _read_scalar { my $self = shift; my $string = shift; return undef if $string eq '~'; return {} if $string eq '{}'; return [] if $string eq '[]'; if ( $string eq '>' || $string eq '|' ) { my ( $line, $indent ) = $self->_peek; die "Multi-line scalar content missing" unless defined $line; my @multiline = ($line); while (1) { $self->_next; my ( $next, $ind ) = $self->_peek; last if $ind < $indent; my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : ''; push @multiline, $pad . $next; } return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n"; } if ( $string =~ /^ ' (.*) ' $/x ) { ( my $rv = $1 ) =~ s/''/'/g; return $rv; } if ( $string =~ $IS_QQ_STRING ) { return $self->_read_qq($string); } if ( $string =~ /^['"]/ ) { # A quote with folding... we don't support that die __PACKAGE__ . " does not support multi-line quoted scalars"; } # Regular unquoted string return $string; } sub _read_nested { my $self = shift; my ( $line, $indent ) = $self->_peek; if ( $line =~ /^ -/x ) { return $self->_read_array($indent); } elsif ( $line =~ $IS_HASH_KEY ) { return $self->_read_hash( $line, $indent ); } else { die "Unsupported YAMLish syntax: '$line'"; } } # Parse an array sub _read_array { my ( $self, $limit ) = @_; my $ar = []; while (1) { my ( $line, $indent ) = $self->_peek; last if $indent < $limit || !defined $line || $line =~ $IS_END_YAML; if ( $indent > $limit ) { die "Array line over-indented"; } if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) { $indent += length $1; $line =~ s/-\s+//; push @$ar, $self->_read_hash( $line, $indent ); } elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) { die "Unexpected start of YAMLish" if $line =~ /^---/; $self->_next; push @$ar, $self->_read_scalar($1); } elsif ( $line =~ /^ - \s* $/x ) { $self->_next; push @$ar, $self->_read_nested; } elsif ( $line =~ $IS_HASH_KEY ) { $self->_next; push @$ar, $self->_read_hash( $line, $indent, ); } else { die "Unsupported YAMLish syntax: '$line'"; } } return $ar; } sub _read_hash { my ( $self, $line, $limit ) = @_; my $indent; my $hash = {}; while (1) { die "Badly formed hash line: '$line'" unless $line =~ $HASH_LINE; my ( $key, $value ) = ( $self->_read_scalar($1), $2 ); $self->_next; my ( $next_line, $next_indent ) = $self->_peek; if ( defined $value ) { $hash->{$key} = $self->_read_scalar($value); } elsif (not defined $value # no explicit undef ("~") given and $next_indent <= $limit # next line is same or less indentation and $next_line !~ $IS_ARRAY_LINE) # arrays can start at same indent { $hash->{$key} = undef; } else { $hash->{$key} = $self->_read_nested; } ( $line, $indent ) = $self->_peek; last if $indent < $limit || !defined $line || $line =~ $IS_END_YAML; } return $hash; } 1; __END__ =pod =head1 NAME TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION Version 3.48 =head1 SYNOPSIS =head1 DESCRIPTION Note that parts of this code were derived from L with the permission of Adam Kennedy. =head1 METHODS =head2 Class Methods =head3 C The constructor C creates and returns an empty C object. my $reader = TAP::Parser::YAMLish::Reader->new; =head2 Instance Methods =head3 C my $got = $reader->read($iterator); Read YAMLish from a L and return the data structure it represents. =head3 C my $source = $reader->get_source; Return the raw YAMLish source from the most recent C. =head1 AUTHOR Andy Armstrong, Adam Kennedy wrote L which provided the template and many of the YAML matching regular expressions for this module. =head1 SEE ALSO L, L, L, L, L, L =head1 COPYRIGHT Copyright 2007-2011 Andy Armstrong. Portions copyright 2006-2008 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Test-Harness-3.48/lib/TAP/Parser/Scheduler.pm0000644000175000017500000002642714506605636017744 0ustar leontleontpackage TAP::Parser::Scheduler; use strict; use warnings; use Carp; use TAP::Parser::Scheduler::Job; use TAP::Parser::Scheduler::Spinner; =head1 NAME TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Scheduler; =head1 DESCRIPTION =head1 METHODS =head2 Class Methods =head3 C my $sched = TAP::Parser::Scheduler->new(tests => \@tests); my $sched = TAP::Parser::Scheduler->new( tests => [ ['t/test_name.t','Test Description'], ... ], rules => \%rules, ); Given 'tests' and optional 'rules' as input, returns a new C object. Each member of C<@tests> should be either a a test file name, or a two element arrayref, where the first element is a test file name, and the second element is a test description. By default, we'll use the test name as the description. The optional C attribute provides direction on which tests should be run in parallel and which should be run sequentially. If no rule data structure is provided, a default data structure is used which makes every test eligible to be run in parallel: { par => '**' }, The rules data structure is documented more in the next section. =head2 Rules data structure The "C" data structure is the the heart of the scheduler. It allows you to express simple rules like "run all tests in sequence" or "run all tests in parallel except these five tests.". However, the rules structure also supports glob-style pattern matching and recursive definitions, so you can also express arbitarily complicated patterns. The rule must only have one top level key: either 'par' for "parallel" or 'seq' for "sequence". Values must be either strings with possible glob-style matching, or arrayrefs of strings or hashrefs which follow this pattern recursively. Every element in an arrayref directly below a 'par' key is eligible to be run in parallel, while vavalues directly below a 'seq' key must be run in sequence. =head3 Rules examples Here are some examples: # All tests be run in parallel (the default rule) { par => '**' }, # Run all tests in sequence, except those starting with "p" { par => 't/p*.t' }, # Run all tests in parallel, except those starting with "p" { seq => [ { seq => 't/p*.t' }, { par => '**' }, ], } # Run some startup tests in sequence, then some parallel tests then some # teardown tests in sequence. { seq => [ { seq => 't/startup/*.t' }, { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } { seq => 't/shutdown/*.t' }, ], }, =head3 Rules resolution =over 4 =item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one. =item * "First match wins". The first rule that matches a test will be the one that applies. =item * Any test which does not match a rule will be run in sequence at the end of the run. =item * The existence of a rule does not imply selecting a test. You must still specify the tests to run. =item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C in your Harness object. =back =head3 Glob-style pattern matching for rules We implement our own glob-style pattern matching. Here are the patterns it supports: ** is any number of characters, including /, within a pathname * is zero or more characters within a filename/directory name ? is exactly one character within a filename/directory name {foo,bar,baz} is any of foo, bar or baz. \ is an escape character =cut sub new { my $class = shift; croak "Need a number of key, value pairs" if @_ % 2; my %args = @_; my $tests = delete $args{tests} || croak "Need a 'tests' argument"; my $rules = delete $args{rules} || { par => '**' }; croak "Unknown arg(s): ", join ', ', sort keys %args if keys %args; # Turn any simple names into a name, description pair. TODO: Maybe # construct jobs here? my $self = bless {}, $class; $self->_set_rules( $rules, $tests ); return $self; } # Build the scheduler data structure. # # SCHEDULER-DATA ::= JOB # || ARRAY OF ARRAY OF SCHEDULER-DATA # # The nested arrays are the key to scheduling. The outer array contains # a list of things that may be executed in parallel. Whenever an # eligible job is sought any element of the outer array that is ready to # execute can be selected. The inner arrays represent sequential # execution. They can only proceed when the first job is ready to run. sub _set_rules { my ( $self, $rules, $tests ) = @_; # Convert all incoming tests to job objects. # If no test description is provided use the file name as the description. my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) } map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests; my $schedule = $self->_rule_clause( $rules, \@tests ); # If any tests are left add them as a sequential block at the end of # the run. $schedule = [ [ $schedule, @tests ] ] if @tests; $self->{schedule} = $schedule; } sub _rule_clause { my ( $self, $rule, $tests ) = @_; croak 'Rule clause must be a hash' unless 'HASH' eq ref $rule; my @type = keys %$rule; croak 'Rule clause must have exactly one key' unless @type == 1; my %handlers = ( par => sub { [ map { [$_] } @_ ]; }, seq => sub { [ [@_] ] }, ); my $handler = $handlers{ $type[0] } || croak 'Unknown scheduler type: ', $type[0]; my $val = $rule->{ $type[0] }; return $handler->( map { 'HASH' eq ref $_ ? $self->_rule_clause( $_, $tests ) : $self->_expand( $_, $tests ) } 'ARRAY' eq ref $val ? @$val : $val ); } sub _glob_to_regexp { my ( $self, $glob ) = @_; my $nesting; my $pattern; while (1) { if ( $glob =~ /\G\*\*/gc ) { # ** is any number of characters, including /, within a pathname $pattern .= '.*?'; } elsif ( $glob =~ /\G\*/gc ) { # * is zero or more characters within a filename/directory name $pattern .= '[^/]*'; } elsif ( $glob =~ /\G\?/gc ) { # ? is exactly one character within a filename/directory name $pattern .= '[^/]'; } elsif ( $glob =~ /\G\{/gc ) { # {foo,bar,baz} is any of foo, bar or baz. $pattern .= '(?:'; ++$nesting; } elsif ( $nesting and $glob =~ /\G,/gc ) { # , is only special inside {} $pattern .= '|'; } elsif ( $nesting and $glob =~ /\G\}/gc ) { # } that matches { is special. But unbalanced } are not. $pattern .= ')'; --$nesting; } elsif ( $glob =~ /\G(\\.)/gc ) { # A quoted literal $pattern .= $1; } elsif ( $glob =~ /\G([\},])/gc ) { # Sometimes meta characters $pattern .= '\\' . $1; } else { # Eat everything that is not a meta character. $glob =~ /\G([^{?*\\\},]*)/gc; $pattern .= quotemeta $1; } return $pattern if pos $glob == length $glob; } } sub _expand { my ( $self, $name, $tests ) = @_; my $pattern = $self->_glob_to_regexp($name); $pattern = qr/^ $pattern $/x; my @match = (); for ( my $ti = 0; $ti < @$tests; $ti++ ) { if ( $tests->[$ti]->filename =~ $pattern ) { push @match, splice @$tests, $ti, 1; $ti--; } } return @match; } =head2 Instance Methods =head3 C Get a list of all remaining tests. =cut sub get_all { my $self = shift; my @all = $self->_gather( $self->{schedule} ); $self->{count} = @all; @all; } sub _gather { my ( $self, $rule ) = @_; return unless defined $rule; return $rule unless 'ARRAY' eq ref $rule; return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule; } =head3 C Return the next available job as L object or C if none are available. Returns a L if the scheduler still has pending jobs but none are available to run right now. =cut sub get_job { my $self = shift; $self->{count} ||= $self->get_all; my @jobs = $self->_find_next_job( $self->{schedule} ); if (@jobs) { --$self->{count}; return $jobs[0]; } return TAP::Parser::Scheduler::Spinner->new if $self->{count}; return; } sub _not_empty { my $ar = shift; return 1 unless 'ARRAY' eq ref $ar; for (@$ar) { return 1 if _not_empty($_); } return; } sub _is_empty { !_not_empty(@_) } sub _find_next_job { my ( $self, $rule ) = @_; my @queue = (); my $index = 0; while ( $index < @$rule ) { my $seq = $rule->[$index]; # Prune any exhausted items. shift @$seq while @$seq && _is_empty( $seq->[0] ); if (@$seq) { if ( defined $seq->[0] ) { if ( 'ARRAY' eq ref $seq->[0] ) { push @queue, $seq; } else { my $job = splice @$seq, 0, 1, undef; $job->on_finish( sub { shift @$seq } ); return $job; } } ++$index; } else { # Remove the empty sub-array from the array splice @$rule, $index, 1; } } for my $seq (@queue) { if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) { return @jobs; } } return; } =head3 C Return a human readable representation of the scheduling tree. For example: my @tests = (qw{ t/startup/foo.t t/shutdown/foo.t t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t }); my $sched = TAP::Parser::Scheduler->new( tests => \@tests, rules => { seq => [ { seq => 't/startup/*.t' }, { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] }, { seq => 't/shutdown/*.t' }, ], }, ); Produces: par: seq: par: seq: par: seq: 't/startup/foo.t' par: seq: 't/a/foo.t' seq: 't/b/foo.t' seq: 't/c/foo.t' par: seq: 't/shutdown/foo.t' 't/d/foo.t' =cut sub as_string { my $self = shift; return $self->_as_string( $self->{schedule} ); } sub _as_string { my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 ); my $pad = ' ' x 2; my $indent = $pad x $depth; if ( !defined $rule ) { return "$indent(undef)\n"; } elsif ( 'ARRAY' eq ref $rule ) { return unless @$rule; my $type = ( 'par', 'seq' )[ $depth % 2 ]; return join( '', "$indent$type:\n", map { $self->_as_string( $_, $depth + 1 ) } @$rule ); } else { return "$indent'" . $rule->filename . "'\n"; } } 1; Test-Harness-3.48/lib/TAP/Parser/Iterator.pm0000644000175000017500000000566614506605636017621 0ustar leontleontpackage TAP::Parser::Iterator; use strict; use warnings; use base 'TAP::Object'; =head1 NAME TAP::Parser::Iterator - Base class for TAP source iterators =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS # to subclass: use TAP::Parser::Iterator (); use base 'TAP::Parser::Iterator'; sub _initialize { # see TAP::Object... } sub next_raw { ... } sub wait { ... } sub exit { ... } =head1 DESCRIPTION This is a simple iterator base class that defines L's iterator API. Iterators are typically created from Ls. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Provided by L. =head2 Instance Methods =head3 C while ( my $item = $iter->next ) { ... } Iterate through it, of course. =head3 C B this method is abstract and should be overridden. while ( my $item = $iter->next_raw ) { ... } Iterate raw input without applying any fixes for quirky input syntax. =cut sub next { my $self = shift; my $line = $self->next_raw; # vms nit: When encountering 'not ok', vms often has the 'not' on a line # by itself: # not # ok 1 - 'I hate VMS' if ( defined($line) and $line =~ /^\s*not\s*$/ ) { $line .= ( $self->next_raw || '' ); } return $line; } sub next_raw { require Carp; my $msg = Carp::longmess('abstract method called directly!'); $_[0]->_croak($msg); } =head3 C If necessary switch the input stream to handle unicode. This only has any effect for I/O handle based streams. The default implementation does nothing. =cut sub handle_unicode { } =head3 C Return a list of filehandles that may be used upstream in a select() call to signal that this Iterator is ready. Iterators that are not handle-based should return an empty list. The default implementation does nothing. =cut sub get_select_handles { return; } =head3 C B this method is abstract and should be overridden. my $wait_status = $iter->wait; Return the C status for this iterator. =head3 C B this method is abstract and should be overridden. my $wait_status = $iter->exit; Return the C status for this iterator. =cut sub wait { require Carp; my $msg = Carp::longmess('abstract method called directly!'); $_[0]->_croak($msg); } sub exit { require Carp; my $msg = Carp::longmess('abstract method called directly!'); $_[0]->_croak($msg); } 1; =head1 SUBCLASSING Please see L for a subclassing overview. You must override the abstract methods as noted above. =head2 Example L is probably the easiest example to follow. There's not much point repeating it here. =head1 SEE ALSO L, L, L, L, L, =cut Test-Harness-3.48/lib/TAP/Parser/Scheduler/0000755000175000017500000000000014506607710017366 5ustar leontleontTest-Harness-3.48/lib/TAP/Parser/Scheduler/Job.pm0000644000175000017500000000423114506605636020443 0ustar leontleontpackage TAP::Parser::Scheduler::Job; use strict; use warnings; use Carp; =head1 NAME TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Scheduler::Job; =head1 DESCRIPTION Represents a single test 'job'. =head1 METHODS =head2 Class Methods =head3 C my $job = TAP::Parser::Scheduler::Job->new( $filename, $description ); Given the filename and description of a test as scalars, returns a new L object. =cut sub new { my ( $class, $name, $desc, @ctx ) = @_; return bless { filename => $name, description => $desc, @ctx ? ( context => \@ctx ) : (), }, $class; } =head2 Instance Methods =head3 C $self->on_finish(\&method). Register a closure to be called when this job is destroyed. The callback will be passed the C object as it's only argument. =cut sub on_finish { my ( $self, $cb ) = @_; $self->{on_finish} = $cb; } =head3 C $self->finish; Called when a job is complete to unlock it. If a callback has been registered with C, it calls it. Otherwise, it does nothing. =cut sub finish { my $self = shift; if ( my $cb = $self->{on_finish} ) { $cb->($self); } } =head2 Attributes $self->filename; $self->description; $self->context; These are all "getters" which return the data set for these attributes during object construction. =head3 C =head3 C =head3 C =cut sub filename { shift->{filename} } sub description { shift->{description} } sub context { @{ shift->{context} || [] } } =head3 C For backwards compatibility in callbacks. =cut sub as_array_ref { my $self = shift; return [ $self->filename, $self->description, $self->{context} ||= [] ]; } =head3 C $self->is_spinner; Returns false indicating that this is a real job rather than a 'spinner'. Spinners are returned when the scheduler still has pending jobs but can't (because of locking) return one right now. =cut sub is_spinner {0} 1; Test-Harness-3.48/lib/TAP/Parser/Scheduler/Spinner.pm0000644000175000017500000000173614506605636021356 0ustar leontleontpackage TAP::Parser::Scheduler::Spinner; use strict; use warnings; use Carp; =head1 NAME TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Scheduler::Spinner; =head1 DESCRIPTION A no-op job. Returned by C as an instruction to the harness to spin (keep executing tests) while the scheduler can't return a real job. =head1 METHODS =head2 Class Methods =head3 C my $job = TAP::Parser::Scheduler::Spinner->new; Ignores any arguments and returns a new C object. =cut sub new { bless {}, shift } =head2 Instance Methods =head3 C Returns true indicating that is a 'spinner' job. Spinners are returned when the scheduler still has pending jobs but can't (because of locking) return one right now. =cut sub is_spinner {1} =head1 SEE ALSO L, L =cut 1; Test-Harness-3.48/lib/TAP/Parser/Iterator/0000755000175000017500000000000014506607710017241 5ustar leontleontTest-Harness-3.48/lib/TAP/Parser/Iterator/Array.pm0000644000175000017500000000324014506605636020661 0ustar leontleontpackage TAP::Parser::Iterator::Array; use strict; use warnings; use base 'TAP::Parser::Iterator'; =head1 NAME TAP::Parser::Iterator::Array - Iterator for array-based TAP sources =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Iterator::Array; my @data = ('foo', 'bar', baz'); my $it = TAP::Parser::Iterator::Array->new(\@data); my $line = $it->next; =head1 DESCRIPTION This is a simple iterator wrapper for arrays of scalar content, used by L. Unless you're writing a plugin or subclassing, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Takes one argument: an C<$array_ref> =head2 Instance Methods =head3 C Iterate through it, of course. =head3 C Iterate raw input without applying any fixes for quirky input syntax. =head3 C Get the wait status for this iterator. For an array iterator this will always be zero. =head3 C Get the exit status for this iterator. For an array iterator this will always be zero. =cut # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $thing ) = @_; chomp @$thing; $self->{idx} = 0; $self->{array} = $thing; $self->{exit} = undef; return $self; } sub wait { shift->exit } sub exit { my $self = shift; return 0 if $self->{idx} >= @{ $self->{array} }; return; } sub next_raw { my $self = shift; return $self->{array}->[ $self->{idx}++ ]; } 1; =head1 ATTRIBUTION Originally ripped off from L. =head1 SEE ALSO L, L, L, =cut Test-Harness-3.48/lib/TAP/Parser/Iterator/Stream.pm0000644000175000017500000000360514506605636021043 0ustar leontleontpackage TAP::Parser::Iterator::Stream; use strict; use warnings; use base 'TAP::Parser::Iterator'; =head1 NAME TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Iterator::Stream; open( TEST, 'test.tap' ); my $it = TAP::Parser::Iterator::Stream->new(\*TEST); my $line = $it->next; =head1 DESCRIPTION This is a simple iterator wrapper for reading from filehandles, used by L. Unless you're writing a plugin or subclassing, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Expects one argument containing a filehandle. =cut # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $thing ) = @_; $self->{fh} = $thing; return $self; } =head2 Instance Methods =head3 C Iterate through it, of course. =head3 C Iterate raw input without applying any fixes for quirky input syntax. =head3 C Get the wait status for this iterator. Always returns zero. =head3 C Get the exit status for this iterator. Always returns zero. =cut sub wait { shift->exit } sub exit { shift->{fh} ? () : 0 } sub next_raw { my $self = shift; my $fh = $self->{fh}; if ( defined( my $line = <$fh> ) ) { chomp $line; return $line; } else { $self->_finish; return; } } sub _finish { my $self = shift; close delete $self->{fh}; } sub get_select_handles { my $self = shift; # return our handle in case it's a socket or pipe (select()-able) return ( $self->{fh}, ) if (-S $self->{fh} || -p $self->{fh}); return; } 1; =head1 ATTRIBUTION Originally ripped off from L. =head1 SEE ALSO L, L, L, =cut Test-Harness-3.48/lib/TAP/Parser/Iterator/Process.pm0000644000175000017500000002206414506605636021226 0ustar leontleontpackage TAP::Parser::Iterator::Process; use strict; use warnings; use Config; use IO::Handle; use base 'TAP::Parser::Iterator'; my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); =head1 NAME TAP::Parser::Iterator::Process - Iterator for process-based TAP sources =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Iterator::Process; my %args = ( command => ['python', 'setup.py', 'test'], merge => 1, setup => sub { ... }, teardown => sub { ... }, ); my $it = TAP::Parser::Iterator::Process->new(\%args); my $line = $it->next; =head1 DESCRIPTION This is a simple iterator wrapper for executing external processes, used by L. Unless you're writing a plugin or subclassing, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C Create an iterator. Expects one argument containing a hashref of the form: command => \@command_to_execute merge => $attempt_merge_stderr_and_stdout? setup => $callback_to_setup_command teardown => $callback_to_teardown_command Tries to uses L & L to communicate with the spawned process if they are available. Falls back onto C. =head2 Instance Methods =head3 C Iterate through the process output, of course. =head3 C Iterate raw input without applying any fixes for quirky input syntax. =head3 C Get the wait status for this iterator's process. =head3 C Get the exit status for this iterator's process. =cut { no warnings 'uninitialized'; # get around a catch22 in the test suite that causes failures on Win32: local $SIG{__DIE__} = undef; eval { require POSIX; &POSIX::WEXITSTATUS(0) }; if ($@) { *_wait2exit = sub { $_[1] >> 8 }; } else { *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) } } } sub _use_open3 { my $self = shift; return unless $Config{d_fork} || $IS_WIN32; for my $module (qw( IPC::Open3 IO::Select )) { eval "use $module"; return if $@; } return 1; } { my $got_unicode; sub _get_unicode { return $got_unicode if defined $got_unicode; eval 'use Encode qw(decode_utf8);'; $got_unicode = $@ ? 0 : 1; } } # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $args ) = @_; my @command = @{ delete $args->{command} || [] } or die "Must supply a command to execute"; $self->{command} = [@command]; # Private. Used to frig with chunk size during testing. my $chunk_size = delete $args->{_chunk_size} || 65536; my $merge = delete $args->{merge}; my ( $pid, $err, $sel ); if ( my $setup = delete $args->{setup} ) { $setup->(@command); } my $out = IO::Handle->new; if ( $self->_use_open3 ) { # HOTPATCH {{{ my $xclose = \&IPC::Open3::xclose; no warnings; local *IPC::Open3::xclose = sub { my $fh = shift; no strict 'refs'; return if ( fileno($fh) == fileno(STDIN) ); $xclose->($fh); }; # }}} if ($IS_WIN32) { $err = $merge ? '' : '>&STDERR'; eval { $pid = open3( '<&STDIN', $out, $merge ? '' : $err, @command ); }; die "Could not execute (@command): $@" if $@; if ( $] >= 5.006 ) { binmode($out, ":crlf"); } } else { $err = $merge ? '' : IO::Handle->new; eval { $pid = open3( '<&STDIN', $out, $err, @command ); }; die "Could not execute (@command): $@" if $@; $sel = $merge ? undef : IO::Select->new( $out, $err ); } } else { $err = ''; my $exec = shift @command; $exec = qq{"$exec"} if $exec =~ /\s/ and -x $exec; my $command = join( ' ', $exec, map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command ); open( $out, "$command|" ) or die "Could not execute ($command): $!"; } $self->{out} = $out; $self->{err} = $err; $self->{sel} = $sel; $self->{pid} = $pid; $self->{exit} = undef; $self->{chunk_size} = $chunk_size; if ( my $teardown = delete $args->{teardown} ) { $self->{teardown} = sub { $teardown->(@command); }; } return $self; } =head3 C Upgrade the input stream to handle UTF8. =cut sub handle_unicode { my $self = shift; if ( $self->{sel} ) { if ( _get_unicode() ) { # Make sure our iterator has been constructed and... my $next = $self->{_next} ||= $self->_next; # ...wrap it to do UTF8 casting $self->{_next} = sub { my $line = $next->(); return decode_utf8($line) if defined $line; return; }; } } else { if ( $] >= 5.008 ) { eval 'binmode($self->{out}, ":utf8")'; } } } ############################################################################## sub wait { shift->{wait} } sub exit { shift->{exit} } sub _next { my $self = shift; if ( my $out = $self->{out} ) { if ( my $sel = $self->{sel} ) { my $err = $self->{err}; my @buf = (); my $partial = ''; # Partial line my $chunk_size = $self->{chunk_size}; return sub { return shift @buf if @buf; READ: while ( my @ready = $sel->can_read ) { for my $fh (@ready) { my $got = sysread $fh, my ($chunk), $chunk_size; if ( $got == 0 ) { $sel->remove($fh); } elsif ( $fh == $err ) { print STDERR $chunk; # echo STDERR } else { $chunk = $partial . $chunk; $partial = ''; # Make sure we have a complete line unless ( substr( $chunk, -1, 1 ) eq "\n" ) { my $nl = rindex $chunk, "\n"; if ( $nl == -1 ) { $partial = $chunk; redo READ; } else { $partial = substr( $chunk, $nl + 1 ); $chunk = substr( $chunk, 0, $nl ); } } push @buf, split /\n/, $chunk; return shift @buf if @buf; } } } # Return partial last line if ( length $partial ) { my $last = $partial; $partial = ''; return $last; } $self->_finish; return; }; } else { return sub { local $/ = "\n"; # to ensure lines if ( defined( my $line = <$out> ) ) { chomp $line; return $line; } $self->_finish; return; }; } } else { return sub { $self->_finish; return; }; } } sub next_raw { my $self = shift; return ( $self->{_next} ||= $self->_next )->(); } sub _finish { my $self = shift; my $status = $?; # Avoid circular refs $self->{_next} = sub {return} if $] >= 5.006; # If we have a subprocess we need to wait for it to terminate if ( defined $self->{pid} ) { if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) { $status = $?; } } ( delete $self->{out} )->close if $self->{out}; # If we have an IO::Select we also have an error handle to close. if ( $self->{sel} ) { ( delete $self->{err} )->close; delete $self->{sel}; } else { $status = $?; } # Sometimes we get -1 on Windows. Presumably that means status not # available. $status = 0 if $IS_WIN32 && $status == -1; $self->{wait} = $status; $self->{exit} = $self->_wait2exit($status); if ( my $teardown = $self->{teardown} ) { $teardown->(); } return $self; } =head3 C Return a list of filehandles that may be used upstream in a select() call to signal that this Iterator is ready. Iterators that are not handle based should return an empty list. =cut sub get_select_handles { my $self = shift; return grep $_, ( $self->{out}, $self->{err} ); } 1; =head1 ATTRIBUTION Originally ripped off from L. =head1 SEE ALSO L, L, L, =cut Test-Harness-3.48/lib/TAP/Parser/Aggregator.pm0000644000175000017500000002203314506605636020075 0ustar leontleontpackage TAP::Parser::Aggregator; use strict; use warnings; use Benchmark; use base 'TAP::Object'; =head1 NAME TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Aggregator; my $aggregate = TAP::Parser::Aggregator->new; $aggregate->add( 't/00-load.t', $load_parser ); $aggregate->add( 't/10-lex.t', $lex_parser ); my $summary = <<'END_SUMMARY'; Passed: %s Failed: %s Unexpectedly succeeded: %s END_SUMMARY printf $summary, scalar $aggregate->passed, scalar $aggregate->failed, scalar $aggregate->todo_passed; =head1 DESCRIPTION C collects parser objects and allows reporting/querying their aggregate results. =head1 METHODS =head2 Class Methods =head3 C my $aggregate = TAP::Parser::Aggregator->new; Returns a new C object. =cut # new() implementation supplied by TAP::Object my %SUMMARY_METHOD_FOR; BEGIN { # install summary methods %SUMMARY_METHOD_FOR = map { $_ => $_ } qw( failed parse_errors passed skipped todo todo_passed total wait exit ); $SUMMARY_METHOD_FOR{total} = 'tests_run'; $SUMMARY_METHOD_FOR{planned} = 'tests_planned'; for my $method ( keys %SUMMARY_METHOD_FOR ) { next if 'total' eq $method; no strict 'refs'; *$method = sub { my $self = shift; return wantarray ? @{ $self->{"descriptions_for_$method"} } : $self->{$method}; }; } } # end install summary methods sub _initialize { my ($self) = @_; $self->{parser_for} = {}; $self->{parse_order} = []; for my $summary ( keys %SUMMARY_METHOD_FOR ) { $self->{$summary} = 0; next if 'total' eq $summary; $self->{"descriptions_for_$summary"} = []; } return $self; } ############################################################################## =head2 Instance Methods =head3 C $aggregate->add( $description => $parser ); The C<$description> is usually a test file name (but only by convention.) It is used as a unique identifier (see e.g. L<"parsers">.) Reusing a description is a fatal error. The C<$parser> is a L object. =cut sub add { my ( $self, $description, $parser ) = @_; if ( exists $self->{parser_for}{$description} ) { $self->_croak( "You already have a parser for ($description)." . " Perhaps you have run the same test twice." ); } push @{ $self->{parse_order} } => $description; $self->{parser_for}{$description} = $parser; while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) { # Slightly nasty. Instead we should maybe have 'cooked' accessors # for results that may be masked by the parser. next if ( $method eq 'exit' || $method eq 'wait' ) && $parser->ignore_exit; if ( my $count = $parser->$method() ) { $self->{$summary} += $count; push @{ $self->{"descriptions_for_$summary"} } => $description; } } return $self; } ############################################################################## =head3 C my $count = $aggregate->parsers; my @parsers = $aggregate->parsers; my @parsers = $aggregate->parsers(@descriptions); In scalar context without arguments, this method returns the number of parsers aggregated. In list context without arguments, returns the parsers in the order they were added. If C<@descriptions> is given, these correspond to the keys used in each call to the add() method. Returns an array of the requested parsers (in the requested order) in list context or an array reference in scalar context. Requesting an unknown identifier is a fatal error. =cut sub parsers { my $self = shift; return $self->_get_parsers(@_) if @_; my $descriptions = $self->{parse_order}; my @parsers = @{ $self->{parser_for} }{@$descriptions}; # Note: Because of the way context works, we must assign the parsers to # the @parsers array or else this method does not work as documented. return @parsers; } sub _get_parsers { my ( $self, @descriptions ) = @_; my @parsers; for my $description (@descriptions) { $self->_croak("A parser for ($description) could not be found") unless exists $self->{parser_for}{$description}; push @parsers => $self->{parser_for}{$description}; } return wantarray ? @parsers : \@parsers; } =head3 C Get an array of descriptions in the order in which they were added to the aggregator. =cut sub descriptions { @{ shift->{parse_order} || [] } } =head3 C Call C immediately before adding any results to the aggregator. Among other times it records the start time for the test run. =cut sub start { my $self = shift; $self->{start_time} = Benchmark->new; } =head3 C Call C immediately after adding all test results to the aggregator. =cut sub stop { my $self = shift; $self->{end_time} = Benchmark->new; } =head3 C Elapsed returns a L object that represents the running time of the aggregated tests. In order for C to be valid you must call C before running the tests and C immediately afterwards. =cut sub elapsed { my $self = shift; require Carp; Carp::croak q{Can't call elapsed without first calling start and then stop} unless defined $self->{start_time} && defined $self->{end_time}; return timediff( $self->{end_time}, $self->{start_time} ); } =head3 C Returns a formatted string representing the runtime returned by C. This lets the caller not worry about Benchmark. =cut sub elapsed_timestr { my $self = shift; my $elapsed = $self->elapsed; return timestr($elapsed); } =head3 C Return true if all the tests passed and no parse errors were detected. =cut sub all_passed { my $self = shift; return $self->total && $self->total == $self->passed && !$self->has_errors; } =head3 C Get a single word describing the status of the aggregated tests. Depending on the outcome of the tests returns 'PASS', 'FAIL' or 'NOTESTS'. This token is understood by L. =cut sub get_status { my $self = shift; my $total = $self->total; my $passed = $self->passed; return ( $self->has_errors || $total != $passed ) ? 'FAIL' : $total ? 'PASS' : 'NOTESTS'; } ############################################################################## =head2 Summary methods Each of the following methods will return the total number of corresponding tests if called in scalar context. If called in list context, returns the descriptions of the parsers which contain the corresponding tests (see C for an explanation of description. =over 4 =item * failed =item * parse_errors =item * passed =item * planned =item * skipped =item * todo =item * todo_passed =item * wait =item * exit =back For example, to find out how many tests unexpectedly succeeded (TODO tests which passed when they shouldn't): my $count = $aggregate->todo_passed; my @descriptions = $aggregate->todo_passed; Note that C and C are the totals of the wait and exit statuses of each of the tests. These values are totalled only to provide a true value if any of them are non-zero. =cut ############################################################################## =head3 C my $tests_run = $aggregate->total; Returns the total number of tests run. =cut sub total { shift->{total} } ############################################################################## =head3 C if ( $parser->has_problems ) { ... } Identical to C, but also returns true if any TODO tests unexpectedly succeeded. This is more akin to "warnings". =cut sub has_problems { my $self = shift; return $self->todo_passed || $self->has_errors; } ############################################################################## =head3 C if ( $parser->has_errors ) { ... } Returns true if I of the parsers failed. This includes: =over 4 =item * Failed tests =item * Parse errors =item * Bad exit or wait status =back =cut sub has_errors { my $self = shift; return $self->failed || $self->parse_errors || $self->exit || $self->wait; } ############################################################################## =head3 C # deprecated in favor of 'todo_passed'. This method was horribly misnamed. This was a badly misnamed method. It indicates which TODO tests unexpectedly succeeded. Will now issue a warning and call C. =cut sub todo_failed { warn '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; goto &todo_passed; } =head1 See Also L L =cut 1; Test-Harness-3.48/lib/TAP/Parser/IteratorFactory.pm0000644000175000017500000002016314506605636021136 0ustar leontleontpackage TAP::Parser::IteratorFactory; use strict; use warnings; use Carp qw( confess ); use File::Basename qw( fileparse ); use base 'TAP::Object'; use constant handlers => []; =head1 NAME TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::IteratorFactory; my $factory = TAP::Parser::IteratorFactory->new({ %config }); my $iterator = $factory->make_iterator( $filename ); =head1 DESCRIPTION This is a factory class that takes a L and runs it through all the registered Ls to see which one should handle the source. If you're a plugin author, you'll be interested in how to Ls, how L works. =head1 METHODS =head2 Class Methods =head3 C Creates a new factory class: my $sf = TAP::Parser::IteratorFactory->new( $config ); C<$config> is optional. If given, sets L and calls L. =cut sub _initialize { my ( $self, $config ) = @_; $self->config( $config || {} )->load_handlers; return $self; } =head3 C Registers a new L with this factory. __PACKAGE__->register_handler( $handler_class ); =head3 C List of handlers that have been registered. =cut sub register_handler { my ( $class, $dclass ) = @_; confess("$dclass must implement can_handle & make_iterator methods!") unless UNIVERSAL::can( $dclass, 'can_handle' ) && UNIVERSAL::can( $dclass, 'make_iterator' ); my $handlers = $class->handlers; push @{$handlers}, $dclass unless grep { $_ eq $dclass } @{$handlers}; return $class; } ############################################################################## =head2 Instance Methods =head3 C my $cfg = $sf->config; $sf->config({ Perl => { %config } }); Chaining getter/setter for the configuration of the available source handlers. This is a hashref keyed on handler class whose values contain config to be passed onto the handlers during detection & creation. Class names may be fully qualified or abbreviated, eg: # these are equivalent $sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } }); $sf->config({ 'Perl' => { %config } }); =cut sub config { my $self = shift; return $self->{config} unless @_; unless ( 'HASH' eq ref $_[0] ) { $self->_croak('Argument to &config must be a hash reference'); } $self->{config} = shift; return $self; } sub _last_handler { my $self = shift; return $self->{last_handler} unless @_; $self->{last_handler} = shift; return $self; } sub _testing { my $self = shift; return $self->{testing} unless @_; $self->{testing} = shift; return $self; } ############################################################################## =head3 C $sf->load_handlers; Loads the handler classes defined in L. For example, given a config: $sf->config({ MySourceHandler => { some => 'config' }, }); C will attempt to load the C class by looking in C<@INC> for it in this order: TAP::Parser::SourceHandler::MySourceHandler MySourceHandler Cs on error. =cut sub load_handlers { my ($self) = @_; for my $handler ( keys %{ $self->config } ) { my $sclass = $self->_load_handler($handler); # TODO: store which class we loaded anywhere? } return $self; } sub _load_handler { my ( $self, $handler ) = @_; my @errors; for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) { return $dclass if UNIVERSAL::can( $dclass, 'can_handle' ) && UNIVERSAL::can( $dclass, 'make_iterator' ); eval "use $dclass"; if ( my $e = $@ ) { push @errors, $e; next; } return $dclass if UNIVERSAL::can( $dclass, 'can_handle' ) && UNIVERSAL::can( $dclass, 'make_iterator' ); push @errors, "handler '$dclass' does not implement can_handle & make_iterator"; } $self->_croak( "Cannot load handler '$handler': " . join( "\n", @errors ) ); } ############################################################################## =head3 C my $iterator = $src_factory->make_iterator( $source ); Given a L, finds the most suitable L to use to create a L (see L). Dies on error. =cut sub make_iterator { my ( $self, $source ) = @_; $self->_croak('no raw source defined!') unless defined $source->raw; $source->config( $self->config )->assemble_meta; # is the raw source already an object? return $source->raw if ( $source->meta->{is_object} && UNIVERSAL::isa( $source->raw, 'TAP::Parser::SourceHandler' ) ); # figure out what kind of source it is my $sd_class = $self->detect_source($source); $self->_last_handler($sd_class); return if $self->_testing; # create it my $iterator = $sd_class->make_iterator($source); return $iterator; } =head3 C Given a L, detects what kind of source it is and returns I L (the most confident one). Dies on error. The detection algorithm works something like this: for (@registered_handlers) { # ask them how confident they are about handling this source $confidence{$handler} = $handler->can_handle( $source ) } # choose the most confident handler Ties are handled by choosing the first handler. =cut sub detect_source { my ( $self, $source ) = @_; confess('no raw source ref defined!') unless defined $source->raw; # find a list of handlers that can handle this source: my %confidence_for; for my $handler ( @{ $self->handlers } ) { my $confidence = $handler->can_handle($source); # warn "handler: $handler: $confidence\n"; $confidence_for{$handler} = $confidence if $confidence; } if ( !%confidence_for ) { # error: can't detect source my $raw_source_short = substr( ${ $source->raw }, 0, 50 ); confess("Cannot detect source of '$raw_source_short'!"); return; } # if multiple handlers can handle it, choose the most confident one my @handlers = sort { $confidence_for{$b} <=> $confidence_for{$a} } keys %confidence_for; # Check for a tie. if( @handlers > 1 && $confidence_for{$handlers[0]} == $confidence_for{$handlers[1]} ) { my $filename = $source->meta->{file}{basename}; die("There is a tie between $handlers[0] and $handlers[1].\n". "Both voted $confidence_for{$handlers[0]} on $filename.\n"); } # this is really useful for debugging handlers: if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) { warn( "votes: ", join( ', ', map {"$_: $confidence_for{$_}"} @handlers ), "\n" ); } # return 1st return $handlers[0]; } 1; __END__ =head1 SUBCLASSING Please see L for a subclassing overview. =head2 Example If we've done things right, you'll probably want to write a new source, rather than sub-classing this (see L for that). But in case you find the need to... package MyIteratorFactory; use strict; use base 'TAP::Parser::IteratorFactory'; # override source detection algorithm sub detect_source { my ($self, $raw_source_ref, $meta) = @_; # do detective work, using $meta and whatever else... } 1; =head1 AUTHORS Steve Purkis =head1 ATTRIBUTION Originally ripped off from L. Moved out of L & converted to a factory class to support extensible TAP source detective work by Steve Purkis. =head1 SEE ALSO L, L, L, L, L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/Source.pm0000644000175000017500000002251714506605636017262 0ustar leontleontpackage TAP::Parser::Source; use strict; use warnings; use File::Basename qw( fileparse ); use base 'TAP::Object'; use constant BLK_SIZE => 512; =head1 NAME TAP::Parser::Source - a TAP source & meta data about it =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Source; my $source = TAP::Parser::Source->new; $source->raw( \'reference to raw TAP source' ) ->config( \%config ) ->merge( $boolean ) ->switches( \@switches ) ->test_args( \@args ) ->assemble_meta; do { ... } if $source->meta->{is_file}; # see assemble_meta for a full list of data available =head1 DESCRIPTION A TAP I is something that produces a stream of TAP for the parser to consume, such as an executable file, a text file, an archive, an IO handle, a database, etc. Cs encapsulate these I sources, and provide some useful meta data about them. They are used by Ls, which do whatever is required to produce & capture a stream of TAP from the I source, and package it up in a L for the parser to consume. Unless you're writing a new L, a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C my $source = TAP::Parser::Source->new; Returns a new C object. =cut # new() implementation supplied by TAP::Object sub _initialize { my ($self) = @_; $self->meta( {} ); $self->config( {} ); return $self; } ############################################################################## =head2 Instance Methods =head3 C my $raw = $source->raw; $source->raw( $some_value ); Chaining getter/setter for the raw TAP source. This is a reference, as it may contain large amounts of data (eg: raw TAP). =head3 C my $meta = $source->meta; $source->meta({ %some_value }); Chaining getter/setter for meta data about the source. This defaults to an empty hashref. See L for more info. =head3 C True if the source has meta data. =head3 C my $config = $source->config; $source->config({ %some_value }); Chaining getter/setter for the source's configuration, if any has been provided by the user. How it's used is up to you. This defaults to an empty hashref. See L for more info. =head3 C my $merge = $source->merge; $source->config( $bool ); Chaining getter/setter for the flag that dictates whether STDOUT and STDERR should be merged (where appropriate). Defaults to undef. =head3 C my $switches = $source->switches; $source->config([ @switches ]); Chaining getter/setter for the list of command-line switches that should be passed to the source (where appropriate). Defaults to undef. =head3 C my $test_args = $source->test_args; $source->config([ @test_args ]); Chaining getter/setter for the list of command-line arguments that should be passed to the source (where appropriate). Defaults to undef. =cut sub raw { my $self = shift; return $self->{raw} unless @_; $self->{raw} = shift; return $self; } sub meta { my $self = shift; return $self->{meta} unless @_; $self->{meta} = shift; return $self; } sub has_meta { return scalar %{ shift->meta } ? 1 : 0; } sub config { my $self = shift; return $self->{config} unless @_; $self->{config} = shift; return $self; } sub merge { my $self = shift; return $self->{merge} unless @_; $self->{merge} = shift; return $self; } sub switches { my $self = shift; return $self->{switches} unless @_; $self->{switches} = shift; return $self; } sub test_args { my $self = shift; return $self->{test_args} unless @_; $self->{test_args} = shift; return $self; } =head3 C my $meta = $source->assemble_meta; Gathers meta data about the L source, stashes it in L and returns it as a hashref. This is done so that the Ls don't have to repeat common checks. Currently this includes: is_scalar => $bool, is_hash => $bool, is_array => $bool, # for scalars: length => $n has_newlines => $bool # only done if the scalar looks like a filename is_file => $bool, is_dir => $bool, is_symlink => $bool, file => { # only done if the scalar looks like a filename basename => $string, # including ext dir => $string, ext => $string, lc_ext => $string, # system checks exists => $bool, stat => [ ... ], # perldoc -f stat empty => $bool, size => $n, text => $bool, binary => $bool, read => $bool, write => $bool, execute => $bool, setuid => $bool, setgid => $bool, sticky => $bool, is_file => $bool, is_dir => $bool, is_symlink => $bool, # only done if the file's a symlink lstat => [ ... ], # perldoc -f lstat # only done if the file's a readable text file shebang => $first_line, } # for arrays: size => $n, =cut sub assemble_meta { my ($self) = @_; return $self->meta if $self->has_meta; my $meta = $self->meta; my $raw = $self->raw; # rudimentary is object test - if it's blessed it'll # inherit from UNIVERSAL $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0; if ( $meta->{is_object} ) { $meta->{class} = ref($raw); } else { my $ref = lc( ref($raw) ); $meta->{"is_$ref"} = 1; } if ( $meta->{is_scalar} ) { my $source = $$raw; $meta->{length} = length($$raw); $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0; # only do file checks if it looks like a filename if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) { my $file = {}; $file->{exists} = -e $source ? 1 : 0; if ( $file->{exists} ) { $meta->{file} = $file; # avoid extra system calls (see `perldoc -f -X`) $file->{stat} = [ stat(_) ]; $file->{empty} = -z _ ? 1 : 0; $file->{size} = -s _; $file->{text} = -T _ ? 1 : 0; $file->{binary} = -B _ ? 1 : 0; $file->{read} = -r _ ? 1 : 0; $file->{write} = -w _ ? 1 : 0; $file->{execute} = -x _ ? 1 : 0; $file->{setuid} = -u _ ? 1 : 0; $file->{setgid} = -g _ ? 1 : 0; $file->{sticky} = -k _ ? 1 : 0; $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0; $meta->{is_dir} = $file->{is_dir} = -d _ ? 1 : 0; # symlink check requires another system call $meta->{is_symlink} = $file->{is_symlink} = -l $source ? 1 : 0; if ( $file->{is_symlink} ) { $file->{lstat} = [ lstat(_) ]; } # put together some common info about the file ( $file->{basename}, $file->{dir}, $file->{ext} ) = map { defined $_ ? $_ : '' } fileparse( $source, qr/\.[^.]*/ ); $file->{lc_ext} = lc( $file->{ext} ); $file->{basename} .= $file->{ext} if $file->{ext}; if ( !$file->{is_dir} && $file->{read} ) { eval { $file->{shebang} = $self->shebang($$raw); }; if ( my $e = $@ ) { warn $e; } } } } } elsif ( $meta->{is_array} ) { $meta->{size} = $#$raw + 1; } elsif ( $meta->{is_hash} ) { ; # do nothing } return $meta; } =head3 C Get the shebang line for a script file. my $shebang = TAP::Parser::Source->shebang( $some_script ); May be called as a class method =cut { # Global shebang cache. my %shebang_for; sub _read_shebang { my ( $class, $file ) = @_; open my $fh, '<', $file or die "Can't read $file: $!\n"; # Might be a binary file - so read a fixed number of bytes. my $got = read $fh, my ($buf), BLK_SIZE; defined $got or die "I/O error: $!\n"; return $1 if $buf =~ /(.*)/; return; } sub shebang { my ( $class, $file ) = @_; $shebang_for{$file} = $class->_read_shebang($file) unless exists $shebang_for{$file}; return $shebang_for{$file}; } } =head3 C my $config = $source->config_for( $class ); Returns L for the $class given. Class names may be fully qualified or abbreviated, eg: # these are equivalent $source->config_for( 'Perl' ); $source->config_for( 'TAP::Parser::SourceHandler::Perl' ); If a fully qualified $class is given, its abbreviated version is checked first. =cut sub config_for { my ( $self, $class ) = @_; my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ ); my $config = $self->config->{$abbrv_class} || $self->config->{$class}; return $config; } 1; __END__ =head1 AUTHORS Steve Purkis. =head1 SEE ALSO L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/SourceHandler.pm0000644000175000017500000001204214506605636020550 0ustar leontleontpackage TAP::Parser::SourceHandler; use strict; use warnings; use TAP::Parser::Iterator (); use base 'TAP::Object'; =head1 NAME TAP::Parser::SourceHandler - Base class for different TAP source handlers =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS # abstract class - don't use directly! # see TAP::Parser::IteratorFactory for general usage # must be sub-classed for use package MySourceHandler; use base 'TAP::Parser::SourceHandler'; sub can_handle { return $confidence_level } sub make_iterator { return $iterator } # see example below for more details =head1 DESCRIPTION This is an abstract base class for L handlers / handlers. A C does whatever is necessary to produce & capture a stream of TAP from the I source, and package it up in a L for the parser to consume. C must implement the I interface used by L. At 2 methods, the interface is pretty simple: L and L. Unless you're writing a new L, a plugin, or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C I. my $vote = $class->can_handle( $source ); C<$source> is a L. Returns a number between C<0> & C<1> reflecting how confidently the raw source can be handled. For example, C<0> means the source cannot handle it, C<0.5> means it may be able to, and C<1> means it definitely can. See L for details on how this is used. =cut sub can_handle { my ( $class, $args ) = @_; $class->_croak( "Abstract method 'can_handle' not implemented for $class!"); return; } =head3 C I. my $iterator = $class->make_iterator( $source ); C<$source> is a L. Returns a new L object for use by the L. Cs on error. =cut sub make_iterator { my ( $class, $args ) = @_; $class->_croak( "Abstract method 'make_iterator' not implemented for $class!"); return; } 1; __END__ =head1 SUBCLASSING Please see L for a subclassing overview, and any of the subclasses that ship with this module as an example. What follows is a quick overview. Start by familiarizing yourself with L and L. L is the easiest sub-class to use as an example. It's important to point out that if you want your subclass to be automatically used by L you'll have to and make sure it gets loaded somehow. If you're using L you can write an L plugin. If you're using L or L directly (e.g. through a custom script, L, or L) you can use the C option which will cause L to load your subclass). Don't forget to register your class with L. =head2 Example package MySourceHandler; use strict; use MySourceHandler; # see TAP::Parser::SourceHandler use TAP::Parser::IteratorFactory; use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler( __PACKAGE__ ); sub can_handle { my ( $class, $src ) = @_; my $meta = $src->meta; my $config = $src->config_for( $class ); if ($config->{accept_all}) { return 1.0; } elsif (my $file = $meta->{file}) { return 0.0 unless $file->{exists}; return 1.0 if $file->{lc_ext} eq '.tap'; return 0.9 if $file->{shebang} && $file->{shebang} =~ /^#!.+tap/; return 0.5 if $file->{text}; return 0.1 if $file->{binary}; } elsif ($meta->{scalar}) { return 0.8 if $$raw_source_ref =~ /\d\.\.\d/; return 0.6 if $meta->{has_newlines}; } elsif ($meta->{array}) { return 0.8 if $meta->{size} < 5; return 0.6 if $raw_source_ref->[0] =~ /foo/; return 0.5; } elsif ($meta->{hash}) { return 0.6 if $raw_source_ref->{foo}; return 0.2; } return 0; } sub make_iterator { my ($class, $source) = @_; # this is where you manipulate the source and # capture the stream of TAP in an iterator # either pick a TAP::Parser::Iterator::* or write your own... my $iterator = TAP::Parser::Iterator::Array->new([ 'foo', 'bar' ]); return $iterator; } 1; =head1 AUTHORS TAPx Developers. Source detection stuff added by Steve Purkis =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/ResultFactory.pm0000644000175000017500000000774114506605636020632 0ustar leontleontpackage TAP::Parser::ResultFactory; use strict; use warnings; use TAP::Parser::Result::Bailout (); use TAP::Parser::Result::Comment (); use TAP::Parser::Result::Plan (); use TAP::Parser::Result::Pragma (); use TAP::Parser::Result::Test (); use TAP::Parser::Result::Unknown (); use TAP::Parser::Result::Version (); use TAP::Parser::Result::YAML (); use base 'TAP::Object'; ############################################################################## =head1 NAME TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 SYNOPSIS use TAP::Parser::ResultFactory; my $token = {...}; my $factory = TAP::Parser::ResultFactory->new; my $result = $factory->make_result( $token ); =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head2 DESCRIPTION This is a simple factory class which returns a L subclass representing the current bit of test data from TAP (usually a single line). It is used primarily by L. Unless you're subclassing, you probably won't need to use this module directly. =head2 METHODS =head2 Class Methods =head3 C Creates a new factory class. I You currently don't need to instantiate a factory in order to use it. =head3 C Returns an instance the appropriate class for the test token passed in. my $result = TAP::Parser::ResultFactory->make_result($token); Can also be called as an instance method. =cut sub make_result { my ( $proto, $token ) = @_; my $type = $token->{type}; return $proto->class_for($type)->new($token); } =head3 C Takes one argument: C<$type>. Returns the class for this $type, or Cs with an error. =head3 C Takes two arguments: C<$type>, C<$class> This lets you override an existing type with your own custom type, or register a completely new type, eg: # create a custom result type: package MyResult; use strict; use base 'TAP::Parser::Result'; # register with the factory: TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); # use it: my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } ); Your custom type should then be picked up automatically by the L. =cut our %CLASS_FOR = ( plan => 'TAP::Parser::Result::Plan', pragma => 'TAP::Parser::Result::Pragma', test => 'TAP::Parser::Result::Test', comment => 'TAP::Parser::Result::Comment', bailout => 'TAP::Parser::Result::Bailout', version => 'TAP::Parser::Result::Version', unknown => 'TAP::Parser::Result::Unknown', yaml => 'TAP::Parser::Result::YAML', ); sub class_for { my ( $class, $type ) = @_; # return target class: return $CLASS_FOR{$type} if exists $CLASS_FOR{$type}; # or complain: require Carp; Carp::croak("Could not determine class for result type '$type'"); } sub register_type { my ( $class, $type, $rclass ) = @_; # register it blindly, assume they know what they're doing $CLASS_FOR{$type} = $rclass; return $class; } 1; =head1 SUBCLASSING Please see L for a subclassing overview. There are a few things to bear in mind when creating your own C: =over 4 =item 1 The factory itself is never instantiated (this I change in the future). This means that C<_initialize> is never called. =item 2 Cnew> is never called, $tokens are reblessed. This I change in a future version! =item 3 L subclasses will register themselves with L directly: package MyFooResult; TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ ); Of course, it's up to you to decide whether or not to ignore them. =back =head2 Example package MyResultFactory; use strict; use MyResult; use base 'TAP::Parser::ResultFactory'; # force all results to be 'MyResult' sub class_for { return 'MyResult'; } 1; =head1 SEE ALSO L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/Multiplexer.pm0000644000175000017500000001033514506605636020327 0ustar leontleontpackage TAP::Parser::Multiplexer; use strict; use warnings; use IO::Select; use Errno; use base 'TAP::Object'; use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/; use constant IS_VMS => $^O eq 'VMS'; use constant SELECT_OK => !( IS_VMS || IS_WIN32 ); =head1 NAME TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Multiplexer; my $mux = TAP::Parser::Multiplexer->new; $mux->add( $parser1, $stash1 ); $mux->add( $parser2, $stash2 ); while ( my ( $parser, $stash, $result ) = $mux->next ) { # do stuff } =head1 DESCRIPTION C gathers input from multiple TAP::Parsers. Internally it calls select on the input file handles for those parsers to wait for one or more of them to have input available. See L for an example of its use. =head1 METHODS =head2 Class Methods =head3 C my $mux = TAP::Parser::Multiplexer->new; Returns a new C object. =cut # new() implementation supplied by TAP::Object sub _initialize { my $self = shift; $self->{select} = IO::Select->new; $self->{avid} = []; # Parsers that can't select $self->{count} = 0; return $self; } ############################################################################## =head2 Instance Methods =head3 C $mux->add( $parser, $stash ); Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque reference that will be returned from C along with the parser and the next result. =cut sub add { my ( $self, $parser, $stash ) = @_; if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) { my $sel = $self->{select}; # We have to turn handles into file numbers here because by # the time we want to remove them from our IO::Select they # will already have been closed by the iterator. my @filenos = map { fileno $_ } @handles; for my $h (@handles) { $sel->add( [ $h, $parser, $stash, @filenos ] ); } $self->{count}++; } else { push @{ $self->{avid} }, [ $parser, $stash ]; } } =head3 C my $count = $mux->parsers; Returns the number of parsers. Parsers are removed from the multiplexer when their input is exhausted. =cut sub parsers { my $self = shift; return $self->{count} + scalar @{ $self->{avid} }; } sub _iter { my $self = shift; my $sel = $self->{select}; my $avid = $self->{avid}; my @ready = (); return sub { # Drain all the non-selectable parsers first if (@$avid) { my ( $parser, $stash ) = @{ $avid->[0] }; my $result = $parser->next; shift @$avid unless defined $result; return ( $parser, $stash, $result ); } until (@ready) { return unless $sel->count; @ready = $sel->can_read; last if @ready || !$!{EINTR}; } my ( $h, $parser, $stash, @handles ) = @{ shift @ready }; my $result = $parser->next; unless ( defined $result ) { $sel->remove(@handles); $self->{count}--; # Force another can_read - we may now have removed a handle # thought to have been ready. @ready = (); } return ( $parser, $stash, $result ); }; } =head3 C Return a result from the next available parser. Returns a list containing the parser from which the result came, the stash that corresponds with that parser and the result. my ( $parser, $stash, $result ) = $mux->next; If C<$result> is undefined the corresponding parser has reached the end of its input (and will automatically be removed from the multiplexer). When all parsers are exhausted an empty list will be returned. if ( my ( $parser, $stash, $result ) = $mux->next ) { if ( ! defined $result ) { # End of this parser } else { # Process result } } else { # All parsers finished } =cut sub next { my $self = shift; return ( $self->{_iter} ||= $self->_iter )->(); } =head1 See Also L L =cut 1; Test-Harness-3.48/lib/TAP/Parser/SourceHandler/0000755000175000017500000000000014506607710020206 5ustar leontleontTest-Harness-3.48/lib/TAP/Parser/SourceHandler/RawTAP.pm0000644000175000017500000000543214506605636021653 0ustar leontleontpackage TAP::Parser::SourceHandler::RawTAP; use strict; use warnings; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Array (); use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); =head1 NAME TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/array ref. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Source; use TAP::Parser::SourceHandler::RawTAP; my $source = TAP::Parser::Source->new->raw( \"1..1\nok 1\n" ); $source->assemble_meta; my $class = 'TAP::Parser::SourceHandler::RawTAP'; my $vote = $class->can_handle( $source ); my $iter = $class->make_iterator( $source ); =head1 DESCRIPTION This is a I L - it has 2 jobs: 1. Figure out if the L it's given is raw TAP output (L). 2. Creates an iterator for raw TAP output (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C my $vote = $class->can_handle( $source ); Only votes if $source is an array, or a scalar with newlines. Casts the following votes: 0.9 if it's a scalar with '..' in it 0.7 if it's a scalar with 'ok' in it 0.3 if it's just a scalar with newlines 0.5 if it's an array =cut sub can_handle { my ( $class, $src ) = @_; my $meta = $src->meta; return 0 if $meta->{file}; if ( $meta->{is_scalar} ) { return 0 unless $meta->{has_newlines}; return 0.9 if ${ $src->raw } =~ /\d\.\.\d/; return 0.7 if ${ $src->raw } =~ /ok/; return 0.3; } elsif ( $meta->{is_array} ) { return 0.5; } return 0; } =head3 C my $iterator = $class->make_iterator( $source ); Returns a new L for the source. C<$source-Eraw> must be an array ref, or a scalar ref. Cs on error. =cut sub make_iterator { my ( $class, $src ) = @_; my $meta = $src->meta; my $tap_array; if ( $meta->{is_scalar} ) { $tap_array = [ split "\n" => ${ $src->raw } ]; } elsif ( $meta->{is_array} ) { $tap_array = $src->raw; } $class->_croak('No raw TAP found in $source->raw') unless scalar $tap_array; return TAP::Parser::Iterator::Array->new($tap_array); } 1; =head1 SUBCLASSING Please see L for a subclassing overview. =head1 SEE ALSO L, L, L, L, L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/SourceHandler/Handle.pm0000644000175000017500000000513314506605636021746 0ustar leontleontpackage TAP::Parser::SourceHandler::Handle; use strict; use warnings; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Stream (); use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); =head1 NAME TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Source; use TAP::Parser::SourceHandler::Executable; my $source = TAP::Parser::Source->new->raw( \*TAP_FILE ); $source->assemble_meta; my $class = 'TAP::Parser::SourceHandler::Handle'; my $vote = $class->can_handle( $source ); my $iter = $class->make_iterator( $source ); =head1 DESCRIPTION This is a I L class. It has 2 jobs: 1. Figure out if the L it's given is an L or GLOB containing raw TAP output (L). 2. Creates an iterator for IO::Handle's & globs (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C my $vote = $class->can_handle( $source ); Casts the following votes: 0.9 if $source is an IO::Handle 0.8 if $source is a glob =cut sub can_handle { my ( $class, $src ) = @_; my $meta = $src->meta; return 0.9 if $meta->{is_object} && UNIVERSAL::isa( $src->raw, 'IO::Handle' ); return 0.8 if $meta->{is_glob}; return 0; } =head3 C my $iterator = $class->make_iterator( $source ); Returns a new L for the source. =cut sub make_iterator { my ( $class, $source ) = @_; $class->_croak('$source->raw must be a glob ref or an IO::Handle') unless $source->meta->{is_glob} || UNIVERSAL::isa( $source->raw, 'IO::Handle' ); return $class->iterator_class->new( $source->raw ); } =head3 C The class of iterator to use, override if you're sub-classing. Defaults to L. =cut use constant iterator_class => 'TAP::Parser::Iterator::Stream'; 1; =head1 SUBCLASSING Please see L for a subclassing overview. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/SourceHandler/Perl.pm0000644000175000017500000002240514506605636021456 0ustar leontleontpackage TAP::Parser::SourceHandler::Perl; use strict; use warnings; use Config; use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant IS_VMS => ( $^O eq 'VMS' ); use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Process (); use Text::ParseWords qw(shellwords); use base 'TAP::Parser::SourceHandler::Executable'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); =head1 NAME TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Source; use TAP::Parser::SourceHandler::Perl; my $source = TAP::Parser::Source->new->raw( \'script.pl' ); $source->assemble_meta; my $class = 'TAP::Parser::SourceHandler::Perl'; my $vote = $class->can_handle( $source ); my $iter = $class->make_iterator( $source ); =head1 DESCRIPTION This is a I L - it has 2 jobs: 1. Figure out if the L it's given is actually a Perl script (L). 2. Creates an iterator for Perl sources (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C my $vote = $class->can_handle( $source ); Only votes if $source looks like a file. Casts the following votes: 0.9 if it has a shebang ala "#!...perl" 0.3 if it has any shebang 0.8 if it's a .t file 0.9 if it's a .pl file 0.75 if it's in a 't' directory 0.25 by default (backwards compat) =cut sub can_handle { my ( $class, $source ) = @_; my $meta = $source->meta; return 0 unless $meta->{is_file}; my $file = $meta->{file}; my $shebang = $file->{shebang} || ''; if ( $shebang =~ /^#!/ ) { return 0.9 if $shebang =~ /^#!.*\bperl/; # We favour Perl as the interpreter for any shebang to preserve # previous semantics: we used to execute everything via Perl and # relied on it to pass the shebang off to the appropriate # interpreter. return 0.3; } return 0.8 if $file->{lc_ext} eq '.t'; # vote higher than Executable return 0.9 if $file->{lc_ext} eq '.pl'; return 0.75 if $file->{dir} =~ /^t\b/; # vote higher than Executable # backwards compat, always vote: return 0.25; } =head3 C my $iterator = $class->make_iterator( $source ); Constructs & returns a new L for the source. Assumes C<$source-Eraw> contains a reference to the perl script. Cs if the file could not be found. The command to run is built as follows: $perl @switches $perl_script @test_args The perl command to use is determined by L. The command generated is guaranteed to preserve: PERL5LIB PERL5OPT Taint Mode, if set in the script's shebang I the command generated will I respect any shebang line defined in your Perl script. This is only a problem if you have compiled a custom version of Perl or if you want to use a specific version of Perl for one test and a different version for another, for example: #!/path/to/a/custom_perl --some --args #!/usr/local/perl-5.6/bin/perl -w Currently you need to write a plugin to get around this. =cut sub _autoflush_stdhandles { my ($class) = @_; $class->_autoflush( \*STDOUT ); $class->_autoflush( \*STDERR ); } sub make_iterator { my ( $class, $source ) = @_; my $meta = $source->meta; my $perl_script = ${ $source->raw }; $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file}; # TODO: does this really need to be done here? $class->_autoflush_stdhandles; my ( $libs, $switches ) = $class->_mangle_switches( $class->_filter_libs( $class->_switches($source) ) ); $class->_run( $source, $libs, $switches ); } sub _has_taint_switch { my( $class, $switches ) = @_; my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches}; return $has_taint ? 1 : 0; } sub _mangle_switches { my ( $class, $libs, $switches ) = @_; # Taint mode ignores environment variables so we must retranslate # PERL5LIB as -I switches and place PERL5OPT on the command line # in order that it be seen. if ( $class->_has_taint_switch($switches) ) { my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : (); return ( $libs, [ @{$switches}, $class->_libs2switches([@$libs, @perl5lib]), defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : () ], ); } return ( $libs, $switches ); } sub _filter_libs { my ( $class, @switches ) = @_; my $path_sep = $Config{path_sep}; my $path_re = qr{$path_sep}; # Filter out any -I switches to be handled as libs later. # # Nasty kludge. It might be nicer if we got the libs separately # although at least this way we find any -I switches that were # supplied other then as explicit libs. # # We filter out any names containing colons because they will break # PERL5LIB my @libs; my @filtered_switches; for (@switches) { if ( !/$path_re/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { push @libs, $1; } else { push @filtered_switches, $_; } } return \@libs, \@filtered_switches; } sub _iterator_hooks { my ( $class, $source, $libs, $switches ) = @_; my $setup = sub { if ( @{$libs} and !$class->_has_taint_switch($switches) ) { $ENV{PERL5LIB} = join( $Config{path_sep}, grep {defined} @{$libs}, $ENV{PERL5LIB} ); } }; # VMS environment variables aren't guaranteed to reset at the end of # the process, so we need to put PERL5LIB back. my $previous = $ENV{PERL5LIB}; my $teardown = sub { if ( defined $previous ) { $ENV{PERL5LIB} = $previous; } else { delete $ENV{PERL5LIB}; } }; return ( $setup, $teardown ); } sub _run { my ( $class, $source, $libs, $switches ) = @_; my @command = $class->_get_command_for_switches( $source, $switches ) or $class->_croak("No command found!"); my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches ); return $class->_create_iterator( $source, \@command, $setup, $teardown ); } sub _create_iterator { my ( $class, $source, $command, $setup, $teardown ) = @_; return TAP::Parser::Iterator::Process->new( { command => $command, merge => $source->merge, setup => $setup, teardown => $teardown, } ); } sub _get_command_for_switches { my ( $class, $source, $switches ) = @_; my $file = ${ $source->raw }; my @args = @{ $source->test_args || [] }; my $command = $class->get_perl; # XXX don't need to quote if we treat the parts as atoms (except maybe vms) #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); my @command = ( $command, @{$switches}, $file, @args ); return @command; } sub _libs2switches { my $class = shift; return map {"-I$_"} grep {$_} @{ $_[0] }; } =head3 C Decode any taint switches from a Perl shebang line. # $taint will be 't' my $taint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl -t' ); # $untaint will be undefined my $untaint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl' ); =cut sub get_taint { my ( $class, $shebang ) = @_; return unless defined $shebang && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; return $1; } sub _switches { my ( $class, $source ) = @_; my $file = ${ $source->raw }; my @switches = @{ $source->switches || [] }; my $shebang = $source->meta->{file}->{shebang}; return unless defined $shebang; my $taint = $class->get_taint($shebang); push @switches, "-$taint" if defined $taint; # Quote the argument if we're VMS, since VMS will downcase anything # not quoted. if (IS_VMS) { for (@switches) { $_ = qq["$_"]; } } return @switches; } =head3 C Gets the version of Perl currently running the test suite. =cut sub get_perl { my $class = shift; return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; return qq["$^X"] if IS_WIN32 && ( $^X =~ /[^\w\.\/\\]/ ); return $^X; } 1; __END__ =head1 SUBCLASSING Please see L for a subclassing overview. =head2 Example package MyPerlSourceHandler; use strict; use TAP::Parser::SourceHandler::Perl; use base 'TAP::Parser::SourceHandler::Perl'; # use the version of perl from the shebang line in the test file sub get_perl { my $self = shift; if (my $shebang = $self->shebang( $self->{file} )) { $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; return $1 if $1; } return $self->SUPER::get_perl(@_); } =head1 SEE ALSO L, L, L, L, L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/SourceHandler/Executable.pm0000644000175000017500000001002414506605636022627 0ustar leontleontpackage TAP::Parser::SourceHandler::Executable; use strict; use warnings; use File::Spec; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Process (); use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); =head1 NAME TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP source =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Source; use TAP::Parser::SourceHandler::Executable; my $source = TAP::Parser::Source->new->raw(['/usr/bin/ruby', 'mytest.rb']); $source->assemble_meta; my $class = 'TAP::Parser::SourceHandler::Executable'; my $vote = $class->can_handle( $source ); my $iter = $class->make_iterator( $source ); =head1 DESCRIPTION This is an I L - it has 2 jobs: 1. Figure out if the L it's given is an executable command (L). 2. Creates an iterator for executable commands (L). Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C my $vote = $class->can_handle( $source ); Only votes if $source looks like an executable file. Casts the following votes: 0.9 if it's a hash with an 'exec' key 0.8 if it's a .bat file 0.75 if it's got an execute bit set =cut sub can_handle { my ( $class, $src ) = @_; my $meta = $src->meta; if ( $meta->{is_file} ) { my $file = $meta->{file}; return 0.85 if $file->{execute} && $file->{binary}; return 0.8 if $file->{lc_ext} eq '.bat'; return 0.25 if $file->{execute}; } elsif ( $meta->{is_hash} ) { return 0.9 if $src->raw->{exec}; } return 0; } =head3 C my $iterator = $class->make_iterator( $source ); Returns a new L for the source. C<$source-Eraw> must be in one of the following forms: { exec => [ @exec ] } [ @exec ] $file Cs on error. =cut sub make_iterator { my ( $class, $source ) = @_; my $meta = $source->meta; my @command; if ( $meta->{is_hash} ) { @command = @{ $source->raw->{exec} || [] }; } elsif ( $meta->{is_scalar} ) { @command = File::Spec->rel2abs( ${ $source->raw } ) if ${ $source->raw }; } elsif ( $meta->{is_array} ) { @command = @{ $source->raw }; } $class->_croak('No command found in $source->raw!') unless @command; $class->_autoflush( \*STDOUT ); $class->_autoflush( \*STDERR ); push @command, @{ $source->test_args || [] }; return $class->iterator_class->new( { command => \@command, merge => $source->merge } ); } =head3 C The class of iterator to use, override if you're sub-classing. Defaults to L. =cut use constant iterator_class => 'TAP::Parser::Iterator::Process'; # Turns on autoflush for the handle passed sub _autoflush { my ( $class, $flushed ) = @_; my $old_fh = select $flushed; $| = 1; select $old_fh; } 1; =head1 SUBCLASSING Please see L for a subclassing overview. =head2 Example package MyRubySourceHandler; use strict; use Carp qw( croak ); use TAP::Parser::SourceHandler::Executable; use base 'TAP::Parser::SourceHandler::Executable'; # expect $handler->(['mytest.rb', 'cmdline', 'args']); sub make_iterator { my ($self, $source) = @_; my @test_args = @{ $source->test_args }; my $rb_file = $test_args[0]; croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file); return $self->SUPER::raw_source(['/usr/bin/ruby', @test_args]); } =head1 SEE ALSO L, L, L, L, L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/SourceHandler/File.pm0000644000175000017500000000566114506605636021440 0ustar leontleontpackage TAP::Parser::SourceHandler::File; use strict; use warnings; use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Stream (); use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); =head1 NAME TAP::Parser::SourceHandler::File - Stream TAP from a text file. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Source; use TAP::Parser::SourceHandler::File; my $source = TAP::Parser::Source->new->raw( \'file.tap' ); $source->assemble_meta; my $class = 'TAP::Parser::SourceHandler::File'; my $vote = $class->can_handle( $source ); my $iter = $class->make_iterator( $source ); =head1 DESCRIPTION This is a I L - it has 2 jobs: 1. Figure out if the I source it's given is a file containing raw TAP output. See L for more details. 2. Takes raw TAP from the text file given, and converts into an iterator. Unless you're writing a plugin or subclassing L, you probably won't need to use this module directly. =head1 METHODS =head2 Class Methods =head3 C my $vote = $class->can_handle( $source ); Only votes if $source looks like a regular file. Casts the following votes: 0.9 if it's a .tap file 0.9 if it has an extension matching any given in user config. =cut sub can_handle { my ( $class, $src ) = @_; my $meta = $src->meta; my $config = $src->config_for($class); return 0 unless $meta->{is_file}; my $file = $meta->{file}; return 0.9 if $file->{lc_ext} eq '.tap'; if ( my $exts = $config->{extensions} ) { my @exts = ref $exts eq 'ARRAY' ? @$exts : $exts; return 0.9 if grep { lc($_) eq $file->{lc_ext} } @exts; } return 0; } =head3 C my $iterator = $class->make_iterator( $source ); Returns a new L for the source. Cs on error. =cut sub make_iterator { my ( $class, $source ) = @_; $class->_croak('$source->raw must be a scalar ref') unless $source->meta->{is_scalar}; my $file = ${ $source->raw }; my $fh; open( $fh, '<', $file ) or $class->_croak("error opening TAP source file '$file': $!"); return $class->iterator_class->new($fh); } =head3 C The class of iterator to use, override if you're sub-classing. Defaults to L. =cut use constant iterator_class => 'TAP::Parser::Iterator::Stream'; 1; __END__ =head1 CONFIGURATION { extensions => [ @case_insensitive_exts_to_match ] } =head1 SUBCLASSING Please see L for a subclassing overview. =head1 SEE ALSO L, L, L, L, L, L, L =cut Test-Harness-3.48/lib/TAP/Parser/Grammar.pm0000644000175000017500000003671214506605776017417 0ustar leontleontpackage TAP::Parser::Grammar; use strict; use warnings; use TAP::Parser::ResultFactory (); use TAP::Parser::YAMLish::Reader (); use base 'TAP::Object'; =head1 NAME TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =head1 SYNOPSIS use TAP::Parser::Grammar; my $grammar = $self->make_grammar({ iterator => $tap_parser_iterator, parser => $tap_parser, version => 12, }); my $result = $grammar->tokenize; =head1 DESCRIPTION C tokenizes lines from a L and constructs L subclasses to represent the tokens. Do not attempt to use this class directly. It won't make sense. It's mainly here to ensure that we will be able to have pluggable grammars when TAP is expanded at some future date (plus, this stuff was really cluttering the parser). =head1 METHODS =head2 Class Methods =head3 C my $grammar = TAP::Parser::Grammar->new({ iterator => $iterator, parser => $parser, version => $version, }); Returns L grammar object that will parse the TAP stream from the specified iterator. Both C and C are required arguments. If C is not set it defaults to C<12> (see L for more details). =cut # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $args ) = @_; $self->{iterator} = $args->{iterator}; # TODO: accessor $self->{iterator} ||= $args->{stream}; # deprecated $self->{parser} = $args->{parser}; # TODO: accessor $self->set_version( $args->{version} || 12 ); return $self; } my %language_for; { # XXX the 'not' and 'ok' might be on separate lines in VMS ... my $ok = qr/(?:not )?ok\b/; my $num = qr/\d+/; my %v12 = ( version => { syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i, handler => sub { my ( $self, $line ) = @_; my $version = $1; return $self->_make_version_token( $line, $version, ); }, }, plan => { syntax => qr/^1\.\.(\d+)\s*(.*)\z/, handler => sub { my ( $self, $line ) = @_; my ( $tests_planned, $tail ) = ( $1, $2 ); my $explanation = undef; my $skip = ''; if ( $tail =~ /^todo((?:\s+\d+)+)/ ) { my @todo = split /\s+/, _trim($1); return $self->_make_plan_token( $line, $tests_planned, 'TODO', '', \@todo ); } elsif ( 0 == $tests_planned ) { $skip = 'SKIP'; # If we can't match # SKIP the directive should be undef. ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i; } elsif ( $tail !~ /^\s*$/ ) { return $self->_make_unknown_token($line); } $explanation = '' unless defined $explanation; return $self->_make_plan_token( $line, $tests_planned, $skip, $explanation, [] ); }, }, # An optimization to handle the most common test lines without # directives. simple_test => { syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x, handler => sub { my ( $self, $line ) = @_; my ( $ok, $num, $desc ) = ( $1, $2, $3 ); return $self->_make_test_token( $line, $ok, $num, $desc ); }, }, test => { syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x, handler => sub { my ( $self, $line ) = @_; my ( $ok, $num, $desc ) = ( $1, $2, $3 ); my ( $dir, $explanation ) = ( '', '' ); if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* ) \# \s* (SKIP|TODO) \b \s* (.*) $/ix ) { ( $desc, $dir, $explanation ) = ( $1, $2, $3 ); } return $self->_make_test_token( $line, $ok, $num, $desc, $dir, $explanation ); }, }, comment => { syntax => qr/^#(.*)/, handler => sub { my ( $self, $line ) = @_; my $comment = $1; return $self->_make_comment_token( $line, $comment ); }, }, bailout => { syntax => qr/^\s*Bail out!\s*(.*)/, handler => sub { my ( $self, $line ) = @_; my $explanation = $1; return $self->_make_bailout_token( $line, $explanation ); }, }, ); my %v13 = ( %v12, plan => { syntax => qr/^1\.\.(\d+)\s*(?:\s*#\s*SKIP\b(.*))?\z/i, handler => sub { my ( $self, $line ) = @_; my ( $tests_planned, $explanation ) = ( $1, $2 ); my $skip = ( 0 == $tests_planned || defined $explanation ) ? 'SKIP' : ''; $explanation = '' unless defined $explanation; return $self->_make_plan_token( $line, $tests_planned, $skip, $explanation, [] ); }, }, yaml => { syntax => qr/^ (\s+) (---.*) $/x, handler => sub { my ( $self, $line ) = @_; my ( $pad, $marker ) = ( $1, $2 ); return $self->_make_yaml_token( $pad, $marker ); }, }, pragma => { syntax => qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x, handler => sub { my ( $self, $line ) = @_; my $pragmas = $1; return $self->_make_pragma_token( $line, $pragmas ); }, }, ); %language_for = ( '12' => { tokens => \%v12, }, '13' => { tokens => \%v13, setup => sub { shift->{iterator}->handle_unicode; }, }, '14' => { tokens => \%v13, setup => sub { shift->{iterator}->handle_unicode; }, }, ); } ############################################################################## =head2 Instance Methods =head3 C $grammar->set_version(13); Tell the grammar which TAP syntax version to support. The lowest supported version is 12. Although 'TAP version' isn't valid version 12 syntax it is accepted so that higher version numbers may be parsed. =cut sub set_version { my $self = shift; my $version = shift; if ( my $language = $language_for{$version} ) { $self->{version} = $version; $self->{tokens} = $language->{tokens}; if ( my $setup = $language->{setup} ) { $self->$setup(); } $self->_order_tokens; } else { require Carp; Carp::croak("Unsupported syntax version: $version"); } } # Optimization to put the most frequent tokens first. sub _order_tokens { my $self = shift; my %copy = %{ $self->{tokens} }; my @ordered_tokens = grep {defined} map { delete $copy{$_} } qw( simple_test test comment plan ); push @ordered_tokens, values %copy; $self->{ordered_tokens} = \@ordered_tokens; } ############################################################################## =head3 C my $token = $grammar->tokenize; This method will return a L object representing the current line of TAP. =cut sub tokenize { my $self = shift; my $line = $self->{iterator}->next; unless ( defined $line ) { delete $self->{parser}; # break circular ref return; } my $token; for my $token_data ( @{ $self->{ordered_tokens} } ) { if ( $line =~ $token_data->{syntax} ) { my $handler = $token_data->{handler}; $token = $self->$handler($line); last; } } $token = $self->_make_unknown_token($line) unless $token; return $self->{parser}->make_result($token); } ############################################################################## =head3 C my @types = $grammar->token_types; Returns the different types of tokens which this grammar can parse. =cut sub token_types { my $self = shift; return keys %{ $self->{tokens} }; } ############################################################################## =head3 C my $syntax = $grammar->syntax_for($token_type); Returns a pre-compiled regular expression which will match a chunk of TAP corresponding to the token type. For example (not that you should really pay attention to this, C<< $grammar->syntax_for('comment') >> will return C<< qr/^#(.*)/ >>. =cut sub syntax_for { my ( $self, $type ) = @_; return $self->{tokens}->{$type}->{syntax}; } ############################################################################## =head3 C my $handler = $grammar->handler_for($token_type); Returns a code reference which, when passed an appropriate line of TAP, returns the lexed token corresponding to that line. As a result, the basic TAP parsing loop looks similar to the following: my @tokens; my $grammar = TAP::Grammar->new; LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) { for my $type ( $grammar->token_types ) { my $syntax = $grammar->syntax_for($type); if ( $line =~ $syntax ) { my $handler = $grammar->handler_for($type); push @tokens => $grammar->$handler($line); next LINE; } } push @tokens => $grammar->_make_unknown_token($line); } =cut sub handler_for { my ( $self, $type ) = @_; return $self->{tokens}->{$type}->{handler}; } sub _make_version_token { my ( $self, $line, $version ) = @_; return { type => 'version', raw => $line, version => $version, }; } sub _make_plan_token { my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_; if ( $directive eq 'SKIP' && 0 != $tests_planned && $self->{version} < 13 ) { warn "Specified SKIP directive in plan but more than 0 tests ($line)\n"; } return { type => 'plan', raw => $line, tests_planned => $tests_planned, directive => $directive, explanation => _trim($explanation), todo_list => $todo, }; } sub _make_test_token { my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_; return { ok => $ok, # forcing this to be an integer (and not a string) reduces memory # consumption. RT #84939 test_num => ( defined $num ? 0 + $num : undef ), description => _trim($desc), directive => ( defined $dir ? uc $dir : '' ), explanation => _trim($explanation), raw => $line, type => 'test', }; } sub _make_unknown_token { my ( $self, $line ) = @_; return { raw => $line, type => 'unknown', }; } sub _make_comment_token { my ( $self, $line, $comment ) = @_; return { type => 'comment', raw => $line, comment => _trim($comment) }; } sub _make_bailout_token { my ( $self, $line, $explanation ) = @_; return { type => 'bailout', raw => $line, bailout => _trim($explanation) }; } sub _make_yaml_token { my ( $self, $pad, $marker ) = @_; my $yaml = TAP::Parser::YAMLish::Reader->new; my $iterator = $self->{iterator}; # Construct a reader that reads from our input stripping leading # spaces from each line. my $leader = length($pad); my $strip = qr{ ^ (\s{$leader}) (.*) $ }x; my @extra = ($marker); my $reader = sub { return shift @extra if @extra; my $line = $iterator->next; return $2 if $line =~ $strip; return; }; my $data = $yaml->read($reader); # Reconstitute input. This is convoluted. Maybe we should just # record it on the way in... chomp( my $raw = $yaml->get_raw ); $raw =~ s/^/$pad/mg; return { type => 'yaml', raw => $raw, data => $data }; } sub _make_pragma_token { my ( $self, $line, $pragmas ) = @_; return { type => 'pragma', raw => $line, pragmas => [ split /\s*,\s*/, _trim($pragmas) ], }; } sub _trim { my $data = shift; return '' unless defined $data; $data =~ s/^\s+//; $data =~ s/\s+$//; return $data; } 1; =head1 TAP GRAMMAR B This grammar is slightly out of date. There's still some discussion about it and a new one will be provided when we have things better defined. The L does not use a formal grammar because TAP is essentially a stream-based protocol. In fact, it's quite legal to have an infinite stream. For the same reason that we don't apply regexes to streams, we're not using a formal grammar here. Instead, we parse the TAP in lines. For purposes for forward compatibility, any result which does not match the following grammar is currently referred to as L. It is I a parse error. A formal grammar would look similar to the following: (* For the time being, I'm cheating on the EBNF by allowing certain terms to be defined by POSIX character classes by using the following syntax: digit ::= [:digit:] As far as I am aware, that's not valid EBNF. Sue me. I didn't know how to write "char" otherwise (Unicode issues). Suggestions welcome. *) tap ::= version? { comment | unknown } leading_plan lines | lines trailing_plan {comment} version ::= 'TAP version ' positiveInteger {positiveInteger} "\n" leading_plan ::= plan skip_directive? "\n" trailing_plan ::= plan "\n" plan ::= '1..' nonNegativeInteger lines ::= line {line} line ::= (comment | test | unknown | bailout ) "\n" test ::= status positiveInteger? description? directive? status ::= 'not '? 'ok ' description ::= (character - (digit | '#')) {character - '#'} directive ::= todo_directive | skip_directive todo_directive ::= hash_mark 'TODO' ' ' {character} skip_directive ::= hash_mark 'SKIP' ' ' {character} comment ::= hash_mark {character} hash_mark ::= '#' {' '} bailout ::= 'Bail out!' {character} unknown ::= { (character - "\n") } (* POSIX character classes and other terminals *) digit ::= [:digit:] character ::= ([:print:] - "\n") positiveInteger ::= ( digit - '0' ) {digit} nonNegativeInteger ::= digit {digit} =head1 SUBCLASSING Please see L for a subclassing overview. If you I want to subclass L's grammar the best thing to do is read through the code. There's no easy way of summarizing it here. =head1 SEE ALSO L, L, L, L, =cut Test-Harness-3.48/lib/TAP/Harness/0000755000175000017500000000000014506607710015617 5ustar leontleontTest-Harness-3.48/lib/TAP/Harness/Beyond.pod0000644000175000017500000003633512514133675017556 0ustar leontleont=head1 NAME Test::Harness::Beyond - Beyond make test =head1 Beyond make test Test::Harness is responsible for running test scripts, analysing their output and reporting success or failure. When I type F (or F<./Build test>) for a module, Test::Harness is usually used to run the tests (not all modules use Test::Harness but the majority do). To start exploring some of the features of Test::Harness I need to switch from F to the F command (which ships with Test::Harness). For the following examples I'll also need a recent version of Test::Harness installed; 3.14 is current as I write. For the examples I'm going to assume that we're working with a 'normal' Perl module distribution. Specifically I'll assume that typing F or F<./Build> causes the built, ready-to-install module code to be available below ./blib/lib and ./blib/arch and that there's a directory called 't' that contains our tests. Test::Harness isn't hardwired to that configuration but it saves me from explaining which files live where for each example. Back to F; like F it runs a test suite - but it provides far more control over which tests are executed, in what order and how their results are reported. Typically F runs all the test scripts below the 't' directory. To do the same thing with prove I type: prove -rb t The switches here are -r to recurse into any directories below 't' and -b which adds ./blib/lib and ./blib/arch to Perl's include path so that the tests can find the code they will be testing. If I'm testing a module of which an earlier version is already installed I need to be careful about the include path to make sure I'm not running my tests against the installed version rather than the new one that I'm working on. Unlike F, typing F doesn't automatically rebuild my module. If I forget to make before prove I will be testing against older versions of those files - which inevitably leads to confusion. I either get into the habit of typing make && prove -rb t or - if I have no XS code that needs to be built I use the modules below F instead prove -Ilib -r t So far I've shown you nothing that F doesn't do. Let's fix that. =head2 Saved State If I have failing tests in a test suite that consists of more than a handful of scripts and takes more than a few seconds to run it rapidly becomes tedious to run the whole test suite repeatedly as I track down the problems. I can tell prove just to run the tests that are failing like this: prove -b t/this_fails.t t/so_does_this.t That speeds things up but I have to make a note of which tests are failing and make sure that I run those tests. Instead I can use prove's --state switch and have it keep track of failing tests for me. First I do a complete run of the test suite and tell prove to save the results: prove -rb --state=save t That stores a machine readable summary of the test run in a file called '.prove' in the current directory. If I have failures I can then run just the failing scripts like this: prove -b --state=failed I can also tell prove to save the results again so that it updates its idea of which tests failed: prove -b --state=failed,save As soon as one of my failing tests passes it will be removed from the list of failed tests. Eventually I fix them all and prove can find no failing tests to run: Files=0, Tests=0, 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU) Result: NOTESTS As I work on a particular part of my module it's most likely that the tests that cover that code will fail. I'd like to run the whole test suite but have it prioritize these 'hot' tests. I can tell prove to do this: prove -rb --state=hot,save t All the tests will run but those that failed most recently will be run first. If no tests have failed since I started saving state all tests will run in their normal order. This combines full test coverage with early notification of failures. The --state switch supports a number of options; for example to run failed tests first followed by all remaining tests ordered by the timestamps of the test scripts - and save the results - I can use prove -rb --state=failed,new,save t See the prove documentation (type prove --man) for the full list of state options. When I tell prove to save state it writes a file called '.prove' ('_prove' on Windows) in the current directory. It's a YAML document so it's quite easy to write tools of your own that work on the saved test state - but the format isn't officially documented so it might change without (much) warning in the future. =head2 Parallel Testing If my tests take too long to run I may be able to speed them up by running multiple test scripts in parallel. This is particularly effective if the tests are I/O bound or if I have multiple CPU cores. I tell prove to run my tests in parallel like this: prove -rb -j 9 t The -j switch enables parallel testing; the number that follows it is the maximum number of tests to run in parallel. Sometimes tests that pass when run sequentially will fail when run in parallel. For example if two different test scripts use the same temporary file or attempt to listen on the same socket I'll have problems running them in parallel. If I see unexpected failures I need to check my tests to work out which of them are trampling on the same resource and rename temporary files or add locks as appropriate. To get the most performance benefit I want to have the test scripts that take the longest to run start first - otherwise I'll be waiting for the one test that takes nearly a minute to complete after all the others are done. I can use the --state switch to run the tests in slowest to fastest order: prove -rb -j 9 --state=slow,save t =head2 Non-Perl Tests The Test Anything Protocol (http://testanything.org/) isn't just for Perl. Just about any language can be used to write tests that output TAP. There are TAP based testing libraries for C, C++, PHP, Python and many others. If I can't find a TAP library for my language of choice it's easy to generate valid TAP. It looks like this: 1..3 ok 1 - init OK ok 2 - opened file not ok 3 - appended to file The first line is the plan - it specifies the number of tests I'm going to run so that it's easy to check that the test script didn't exit before running all the expected tests. The following lines are the test results - 'ok' for pass, 'not ok' for fail. Each test has a number and, optionally, a description. And that's it. Any language that can produce output like that on STDOUT can be used to write tests. Recently I've been rekindling a two-decades-old interest in Forth. Evidently I have a masochistic streak that even Perl can't satisfy. I want to write tests in Forth and run them using prove (you can find my gforth TAP experiments at https://svn.hexten.net/andy/Forth/Testing/). I can use the --exec switch to tell prove to run the tests using gforth like this: prove -r --exec gforth t Alternately, if the language used to write my tests allows a shebang line I can use that to specify the interpreter. Here's a test written in PHP: #!/usr/bin/php If I save that as t/phptest.t the shebang line will ensure that it runs correctly along with all my other tests. =head2 Mixing it up Subtle interdependencies between test programs can mask problems - for example an earlier test may neglect to remove a temporary file that affects the behaviour of a later test. To find this kind of problem I use the --shuffle and --reverse options to run my tests in random or reversed order. =head2 Rolling My Own If I need a feature that prove doesn't provide I can easily write my own. Typically you'll want to change how TAP gets I into and I from the parser. L supports arbitrary plugins, and L supports custom I and I that you can load using either L or L; there are many examples to base mine on. For more details see L, L, and L. If writing a plugin is not enough, you can write your own test harness; one of the motives for the 3.00 rewrite of Test::Harness was to make it easier to subclass and extend. The Test::Harness module is a compatibility wrapper around TAP::Harness. For new applications I should use TAP::Harness directly. As we'll see, prove uses TAP::Harness. When I run prove it processes its arguments, figures out which test scripts to run and then passes control to TAP::Harness to run the tests, parse, analyse and present the results. By subclassing TAP::Harness I can customise many aspects of the test run. I want to log my test results in a database so I can track them over time. To do this I override the summary method in TAP::Harness. I start with a simple prototype that dumps the results as a YAML document: package My::TAP::Harness; use base 'TAP::Harness'; use YAML; sub summary { my ( $self, $aggregate ) = @_; print Dump( $aggregate ); $self->SUPER::summary( $aggregate ); } 1; I need to tell prove to use my My::TAP::Harness. If My::TAP::Harness is on Perl's @INC include path I can prove --harness=My::TAP::Harness -rb t If I don't have My::TAP::Harness installed on @INC I need to provide the correct path to perl when I run prove: perl -Ilib `which prove` --harness=My::TAP::Harness -rb t I can incorporate these options into my own version of prove. It's pretty simple. Most of the work of prove is handled by App::Prove. The important code in prove is just: use App::Prove; my $app = App::Prove->new; $app->process_args(@ARGV); exit( $app->run ? 0 : 1 ); If I write a subclass of App::Prove I can customise any aspect of the test runner while inheriting all of prove's behaviour. Here's myprove: #!/usr/bin/env perl use lib qw( lib ); # Add ./lib to @INC use App::Prove; my $app = App::Prove->new; # Use custom TAP::Harness subclass $app->harness( 'My::TAP::Harness' ); $app->process_args( @ARGV ); exit( $app->run ? 0 : 1 ); Now I can run my tests like this ./myprove -rb t =head2 Deeper Customisation Now that I know how to subclass and replace TAP::Harness I can replace any other part of the harness. To do that I need to know which classes are responsible for which functionality. Here's a brief guided tour; the default class for each component is shown in parentheses. Normally any replacements I write will be subclasses of these default classes. When I run my tests TAP::Harness creates a scheduler (TAP::Parser::Scheduler) to work out the running order for the tests, an aggregator (TAP::Parser::Aggregator) to collect and analyse the test results and a formatter (TAP::Formatter::Console) to display those results. If I'm running my tests in parallel there may also be a multiplexer (TAP::Parser::Multiplexer) - the component that allows multiple tests to run simultaneously. Once it has created those helpers TAP::Harness starts running the tests. For each test it creates a new parser (TAP::Parser) which is responsible for running the test script and parsing its output. To replace any of these components I call one of these harness methods with the name of the replacement class: aggregator_class formatter_class multiplexer_class parser_class scheduler_class For example, to replace the aggregator I would $harness->aggregator_class( 'My::Aggregator' ); Alternately I can supply the names of my substitute classes to the TAP::Harness constructor: my $harness = TAP::Harness->new( { aggregator_class => 'My::Aggregator' } ); If I need to reach even deeper into the internals of the harness I can replace the classes that TAP::Parser uses to execute test scripts and tokenise their output. Before running a test script TAP::Parser creates a grammar (TAP::Parser::Grammar) to decode the raw TAP into tokens, a result factory (TAP::Parser::ResultFactory) to turn the decoded TAP results into objects and, depending on whether it's running a test script or reading TAP from a file, scalar or array a source or an iterator (TAP::Parser::IteratorFactory). Each of these objects may be replaced by calling one of these parser methods: source_class perl_source_class grammar_class iterator_factory_class result_factory_class =head2 Callbacks As an alternative to subclassing the components I need to change I can attach callbacks to the default classes. TAP::Harness exposes these callbacks: parser_args Tweak the parameters used to create the parser made_parser Just made a new parser before_runtests About to run tests after_runtests Have run all tests after_test Have run an individual test script TAP::Parser also supports callbacks; bailout, comment, plan, test, unknown, version and yaml are called for the corresponding TAP result types, ALL is called for all results, ELSE is called for all results for which a named callback is not installed and EOF is called once at the end of each TAP stream. To install a callback I pass the name of the callback and a subroutine reference to TAP::Harness or TAP::Parser's callback method: $harness->callback( after_test => sub { my ( $script, $desc, $parser ) = @_; } ); I can also pass callbacks to the constructor: my $harness = TAP::Harness->new({ callbacks => { after_test => sub { my ( $script, $desc, $parser ) = @_; # Do something interesting here } } }); When it comes to altering the behaviour of the test harness there's more than one way to do it. Which way is best depends on my requirements. In general if I only want to observe test execution without changing the harness' behaviour (for example to log test results to a database) I choose callbacks. If I want to make the harness behave differently subclassing gives me more control. =head2 Parsing TAP Perhaps I don't need a complete test harness. If I already have a TAP test log that I need to parse all I need is TAP::Parser and the various classes it depends upon. Here's the code I need to run a test and parse its TAP output use TAP::Parser; my $parser = TAP::Parser->new( { source => 't/simple.t' } ); while ( my $result = $parser->next ) { print $result->as_string, "\n"; } Alternately I can pass an open filehandle as source and have the parser read from that rather than attempting to run a test script: open my $tap, '<', 'tests.tap' or die "Can't read TAP transcript ($!)\n"; my $parser = TAP::Parser->new( { source => $tap } ); while ( my $result = $parser->next ) { print $result->as_string, "\n"; } This approach is useful if I need to convert my TAP based test results into some other representation. See TAP::Convert::TET (http://search.cpan.org/dist/TAP-Convert-TET/) for an example of this approach. =head2 Getting Support The Test::Harness developers hang out on the tapx-dev mailing list[1]. For discussion of general, language independent TAP issues there's the tap-l[2] list. Finally there's a wiki dedicated to the Test Anything Protocol[3]. Contributions to the wiki, patches and suggestions are all welcome. =for comment The URLs in [1] and [2] point to 404 pages. What are currently the correct URLs? [1] L [2] L [3] L Test-Harness-3.48/lib/TAP/Harness/Env.pm0000644000175000017500000001245014506605636016714 0ustar leontleontpackage 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.48'; # 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{lib} || [] }; my @raw_switches = @{ delete $input{switches} || [] }; my @opt = ( @raw_switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} || '' ) ); my @switches; while ( my $opt = shift @opt ) { if ( $opt =~ /^ -I (.*) $ /x ) { push @libs, length($1) ? $1 : shift @opt; } else { push @switches, $opt; } } # Do things the old way on VMS... push @libs, _filtered_inc_vms() if IS_VMS; # If $Verbose isn't numeric default to 1. This helps core. my $verbose = $ENV{HARNESS_VERBOSE} ? $ENV{HARNESS_VERBOSE} !~ /\d/ ? 1 : $ENV{HARNESS_VERBOSE} : 0; my %args = ( lib => \@libs, timer => $ENV{HARNESS_TIMER} || 0, switches => \@switches, color => $ENV{HARNESS_COLOR} || 0, verbosity => $verbose, ignore_exit => $ENV{HARNESS_IGNORE_EXIT} || 0, ); my $class = delete $input{harness_class} || $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { for my $opt ( split /:/, $env_opt ) { if ( $opt =~ /^j(\d*)$/ ) { $args{jobs} = $1 || 9; } elsif ( $opt eq 'c' ) { $args{color} = 1; } elsif ( $opt =~ m/^f(.*)$/ ) { my $fmt = $1; $fmt =~ s/-/::/g; $args{formatter_class} = $fmt; } elsif ( $opt =~ m/^a(.*)$/ ) { my $archive = $1; $class = 'TAP::Harness::Archive'; $args{archive} = $archive; } else { die "Unknown HARNESS_OPTIONS item: $opt\n"; } } } return TAP::Object->_construct($class, { %args, %input }); } 1; =head1 NAME TAP::Harness::Env - Parsing harness related environmental variables where appropriate =head1 VERSION Version 3.48 =head1 SYNOPSIS my $harness = TAP::Harness::Env->create(\%extra_args) =head1 DESCRIPTION This module implements the environmental variables that L uses with TAP::Harness, and instantiates the appropriate class with the appropriate arguments. =head1 METHODS =over 4 =item * create( \%args ) This function reads the environment and generates an appropriate argument hash from it. If given any arguments in C<%extra_args>, these will override the environmental defaults. In accepts C (which defaults to C), and any argument the harness class accepts. =back =head1 ENVIRONMENTAL VARIABLES =over 4 =item C Setting this adds perl command line switches to each test file run. For example, C will turn on taint mode. C will run C for each test. =item C If true, C will output the verbose results of running its tests. =item C Specifies a TAP::Harness subclass to be used in place of TAP::Harness. =item C Provide additional options to the harness. Currently supported options are: =over =item C<< j >> Run (default 9) parallel jobs. =item C<< c >> Try to color output. See L. =item C<< a >> Will use L as the harness class, and save the TAP to C =item C<< fPackage-With-Dashes >> Set the formatter_class of the harness being run. Since the C is separated by C<:>, we use C<-> instead. =back Multiple options may be separated by colons: HARNESS_OPTIONS=j9:c make test =item C Setting this to true will make the harness display the number of milliseconds each test took. You can also use F's C<--timer> switch. =item C Attempt to produce color output. =item C If set to a true value instruct C to ignore exit and wait status from test scripts. =back Test-Harness-3.48/lib/TAP/Parser.pm0000644000175000017500000014575014506605636016027 0ustar leontleontpackage 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.48 =cut our $VERSION = '3.48'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 14; $ENV{TAP_VERSION} = $MAX_TAP_VERSION; END { # For VMS. delete $ENV{TAP_VERSION}; } BEGIN { # making accessors __PACKAGE__->mk_methods( qw( _iterator _spool exec exit is_good_plan plan tests_planned tests_run wait version in_todo start_time end_time start_times end_times skip_all grammar_class result_factory_class iterator_factory_class ) ); sub _stream { # deprecated my $self = shift; $self->_iterator(@_); } } # done making accessors =head1 SYNOPSIS use TAP::Parser; my $parser = TAP::Parser->new( { source => $source } ); while ( my $result = $parser->next ) { print $result->as_string; } =head1 DESCRIPTION C is designed to produce a proper parse of TAP output. For an example of how to run tests through this module, see the simple harnesses C. There's a wiki dedicated to the Test Anything Protocol: L It includes the TAP::Parser Cookbook: L =head1 METHODS =head2 Class Methods =head3 C my $parser = TAP::Parser->new(\%args); Returns a new C object. The arguments should be a hashref with I of the following keys: =over 4 =item * C I This is the preferred method of passing input to the constructor. The C is used to create a L that is passed to the L which in turn figures out how to handle the source and creates a for it. The iterator is used by the parser to read in the TAP stream. To configure the I use the C parameter below. Note that C, C and C are I. =item * C I The value should be the complete TAP output. The I is used to create a L that is passed to the L which in turn figures out how to handle the source and creates a for it. The iterator is used by the parser to read in the TAP stream. To configure the I use the C parameter below. Note that C, C and C are I. =item * C Must be passed an array reference. The I array ref is used to create a L that is passed to the L which in turn figures out how to handle the source and creates a for it. The iterator is used by the parser to read in the TAP stream. By default the L class will create a L object to handle the source. This passes the array reference strings as command arguments to L: exec => [ '/usr/bin/ruby', 't/my_test.rb' ] If any C are given they will be appended to the end of the command argument list. To configure the I use the C parameter below. Note that C, C and C are I. =back The following keys are optional. =over 4 =item * C I. If set, C must be a hashref containing the names of the Ls to load and/or configure. The values are a hash of configuration that will be accessible to the source handlers via L. For example: sources => { Perl => { exec => '/path/to/custom/perl' }, File => { extensions => [ '.tap', '.txt' ] }, MyCustom => { some => 'config' }, } This will cause C to pass custom configuration to two of the built- in source handlers - L, L - and attempt to load the C class. See L for more detail. The C parameter affects how C, C and C parameters are handled. See L, L and subclasses for more details. =item * C If present, each callback corresponding to a given result type will be called with the result as the argument if the C method is used: my %callbacks = ( test => \&test_callback, plan => \&plan_callback, comment => \&comment_callback, bailout => \&bailout_callback, unknown => \&unknown_callback, ); my $aggregator = TAP::Parser::Aggregator->new; for my $file ( @test_files ) { my $parser = TAP::Parser->new( { source => $file, callbacks => \%callbacks, } ); $parser->run; $aggregator->add( $file, $parser ); } =item * C If using a Perl file as a source, optional switches may be passed which will be used when invoking the perl executable. my $parser = TAP::Parser->new( { source => $test_file, switches => [ '-Ilib' ], } ); =item * C Used in conjunction with the C and C option to supply a reference to an C<@ARGV> style array of arguments to pass to the test program. =item * C If passed a filehandle will write a copy of all parsed TAP to that handle. =item * C If false, STDERR is not captured (though it is 'relayed' to keep it somewhat synchronized with STDOUT.) If true, STDERR and STDOUT are the same filehandle. This may cause breakage if STDERR contains anything resembling TAP format, but does allow exact synchronization. Subtleties of this behavior may be platform-dependent and may change in the future. =item * C This option was introduced to let you easily customize which I class the parser should use. It defaults to L. See also L. =item * C This option was introduced to let you easily customize which I factory class the parser should use. It defaults to L. See also L. =item * C I This option was introduced to let you easily customize which I factory class the parser should use. It defaults to L. =back =cut # new() implementation supplied by TAP::Base # This should make overriding behaviour of the Parser in subclasses easier: sub _default_grammar_class {'TAP::Parser::Grammar'} sub _default_result_factory_class {'TAP::Parser::ResultFactory'} sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'} ############################################################################## =head2 Instance Methods =head3 C my $parser = TAP::Parser->new( { source => $file } ); while ( my $result = $parser->next ) { print $result->as_string, "\n"; } This method returns the results of the parsing, one result at a time. Note that it is destructive. You can't rewind and examine previous results. If callbacks are used, they will be issued before this call returns. Each result returned is a subclass of L. See that module and related classes for more information on how to use them. =cut sub next { my $self = shift; return ( $self->{_iter} ||= $self->_iter )->(); } ############################################################################## =head3 C $parser->run; This method merely runs the parser and parses all of the TAP. =cut sub run { my $self = shift; while ( defined( my $result = $self->next ) ) { # do nothing } } ############################################################################## =head3 C Make a new L object and return it. Passes through any arguments given. The C can be customized, as described in L. =head3 C Make a new L object using the parser's L, and return it. Passes through any arguments given. The C can be customized, as described in L. =head3 C I. Make a new L object and return it. Passes through any arguments given. C can be customized, as described in L. =cut # This should make overriding behaviour of the Parser in subclasses easier: sub make_iterator_factory { shift->iterator_factory_class->new(@_); } sub make_grammar { shift->grammar_class->new(@_); } sub make_result { shift->result_factory_class->make_result(@_); } { # of the following, anything beginning with an underscore is strictly # internal and should not be exposed. my %initialize = ( version => $DEFAULT_TAP_VERSION, plan => '', # the test plan (e.g., 1..3) tests_run => 0, # actual current test numbers skipped => [], # todo => [], # passed => [], # failed => [], # actual_failed => [], # how many tests really failed actual_passed => [], # how many tests really passed todo_passed => [], # tests which unexpectedly succeed parse_errors => [], # perfect TAP should have none ); # We seem to have this list hanging around all over the place. We could # probably get it from somewhere else to avoid the repetition. my @legal_callback = qw( test version plan comment bailout unknown yaml ALL ELSE EOF ); my @class_overrides = qw( grammar_class result_factory_class iterator_factory_class ); sub _initialize { my ( $self, $arg_for ) = @_; # everything here is basically designed to convert any TAP source to a # TAP::Parser::Iterator. # Shallow copy my %args = %{ $arg_for || {} }; $self->SUPER::_initialize( \%args, \@legal_callback ); # get any class overrides out first: for my $key (@class_overrides) { my $default_method = "_default_$key"; my $val = delete $args{$key} || $self->$default_method(); $self->$key($val); } my $iterator = delete $args{iterator}; $iterator ||= delete $args{stream}; # deprecated my $tap = delete $args{tap}; my $version = delete $args{version}; my $raw_source = delete $args{source}; my $sources = delete $args{sources}; my $exec = delete $args{exec}; my $merge = delete $args{merge}; my $spool = delete $args{spool}; my $switches = delete $args{switches}; my $ignore_exit = delete $args{ignore_exit}; my $test_args = delete $args{test_args} || []; if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) { $self->_croak( "You may only choose one of 'exec', 'tap', 'source' or 'iterator'" ); } if ( my @excess = sort keys %args ) { $self->_croak("Unknown options: @excess"); } # convert $tap & $exec to $raw_source equiv. my $type = ''; my $source = TAP::Parser::Source->new; if ($tap) { $type = 'raw TAP'; $source->raw( \$tap ); } elsif ($exec) { $type = 'exec ' . $exec->[0]; $source->raw( { exec => $exec } ); } elsif ($raw_source) { $type = 'source ' . ref($raw_source) || $raw_source; $source->raw( ref($raw_source) ? $raw_source : \$raw_source ); } elsif ($iterator) { $type = 'iterator ' . ref($iterator); } if ( $source->raw ) { my $src_factory = $self->make_iterator_factory($sources); $source->merge($merge)->switches($switches) ->test_args($test_args); $iterator = $src_factory->make_iterator($source); } unless ($iterator) { $self->_croak( "PANIC: could not determine iterator for input $type"); } while ( my ( $k, $v ) = each %initialize ) { $self->{$k} = 'ARRAY' eq ref $v ? [] : $v; } $self->version($version) if $version; $self->_iterator($iterator); $self->_spool($spool); $self->ignore_exit($ignore_exit); return $self; } } =head1 INDIVIDUAL RESULTS If you've read this far in the docs, you've seen this: while ( my $result = $parser->next ) { print $result->as_string; } Each result returned is a L subclass, referred to as I. =head2 Result types Basically, you fetch individual results from the TAP. The six types, with examples of each, are as follows: =over 4 =item * Version TAP version 12 =item * Plan 1..42 =item * Pragma pragma +strict =item * Test ok 3 - We should start with some foobar! =item * Comment # Hope we don't use up the foobar. =item * Bailout Bail out! We ran out of foobar! =item * Unknown ... yo, this ain't TAP! ... =back Each result fetched is a result object of a different type. There are common methods to each result object and different types may have methods unique to their type. Sometimes a type method may be overridden in a subclass, but its use is guaranteed to be identical. =head2 Common type methods =head3 C Returns the type of result, such as C or C. =head3 C Prints a string representation of the token. This might not be the exact output, however. Tests will have test numbers added if not present, TODO and SKIP directives will be capitalized and, in general, things will be cleaned up. If you need the original text for the token, see the C method. =head3 C Returns the original line of text which was parsed. =head3 C Indicates whether or not this is the test plan line. =head3 C Indicates whether or not this is a test line. =head3 C Indicates whether or not this is a comment. Comments will generally only appear in the TAP stream if STDERR is merged to STDOUT. See the C option. =head3 C Indicates whether or not this is bailout line. =head3 C Indicates whether or not the current item is a YAML block. =head3 C Indicates whether or not the current line could be parsed. =head3 C if ( $result->is_ok ) { ... } Reports whether or not a given result has passed. Anything which is B a test result returns true. This is merely provided as a convenient shortcut which allows you to do this: my $parser = TAP::Parser->new( { source => $source } ); while ( my $result = $parser->next ) { # only print failing results print $result->as_string unless $result->is_ok; } =head2 C methods if ( $result->is_plan ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C if ( $result->is_plan ) { print $result->plan; } This is merely a synonym for C. =head3 C my $directive = $result->directive; If a SKIP directive is included with the plan, this method will return it. 1..0 # SKIP: why bother? =head3 C my $explanation = $result->explanation; If a SKIP directive was included with the plan, this method will return the explanation, if any. =head2 C methods if ( $result->is_pragma ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C Returns a list of pragmas each of which is a + or - followed by the pragma name. =head2 C methods if ( $result->is_comment ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C if ( $result->is_comment ) { my $comment = $result->comment; print "I have something to say: $comment"; } =head2 C methods if ( $result->is_bailout ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C if ( $result->is_bailout ) { my $explanation = $result->explanation; print "We bailed out because ($explanation)"; } If, and only if, a token is a bailout token, you can get an "explanation" via this method. The explanation is the text after the mystical "Bail out!" words which appear in the tap output. =head2 C methods if ( $result->is_unknown ) { ... } There are no unique methods for unknown results. =head2 C methods if ( $result->is_test ) { ... } If the above evaluates as true, the following methods will be available on the C<$result> object. =head3 C my $ok = $result->ok; Returns the literal text of the C or C status. =head3 C my $test_number = $result->number; Returns the number of the test, even if the original TAP output did not supply that number. =head3 C my $description = $result->description; Returns the description of the test, if any. This is the portion after the test number but before the directive. =head3 C my $directive = $result->directive; Returns either C or C if either directive was present for a test line. =head3 C my $explanation = $result->explanation; If a test had either a C or C directive, this method will return the accompanying explanation, if present. not ok 17 - 'Pigs can fly' # TODO not enough acid For the above line, the explanation is I. =head3 C if ( $result->is_ok ) { ... } Returns a boolean value indicating whether or not the test passed. Remember that for TODO tests, the test always passes. B this was formerly C. The latter method is deprecated and will issue a warning. =head3 C if ( $result->is_actual_ok ) { ... } Returns a boolean value indicating whether or not the test passed, regardless of its TODO status. B this was formerly C. The latter method is deprecated and will issue a warning. =head3 C if ( $test->is_unplanned ) { ... } If a test number is greater than the number of planned tests, this method will return true. Unplanned tests will I return false for C, regardless of whether or not the test C (see L for more information about this). =head3 C if ( $result->has_skip ) { ... } Returns a boolean value indicating whether or not this test had a SKIP directive. =head3 C if ( $result->has_todo ) { ... } Returns a boolean value indicating whether or not this test had a TODO directive. Note that TODO tests I pass. If you need to know whether or not they really passed, check the C method. =head3 C if ( $parser->in_todo ) { ... } True while the most recent result was a TODO. Becomes true before the TODO result is returned and stays true until just before the next non- TODO test is returned. =head1 TOTAL RESULTS After parsing the TAP, there are many methods available to let you dig through the results and determine what is meaningful to you. =head2 Individual Results These results refer to individual tests which are run. =head3 C my @passed = $parser->passed; # the test numbers which passed my $passed = $parser->passed; # the number of tests which passed This method lets you know which (or how many) tests passed. If a test failed but had a TODO directive, it will be counted as a passed test. =cut sub passed { return @{ $_[0]->{passed} } if ref $_[0]->{passed}; return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{passed}; } =head3 C my @failed = $parser->failed; # the test numbers which failed my $failed = $parser->failed; # the number of tests which failed This method lets you know which (or how many) tests failed. If a test passed but had a TODO directive, it will B be counted as a failed test. =cut sub failed { @{ shift->{failed} } } =head3 C # the test numbers which actually passed my @actual_passed = $parser->actual_passed; # the number of tests which actually passed my $actual_passed = $parser->actual_passed; This method lets you know which (or how many) tests actually passed, regardless of whether or not a TODO directive was found. =cut sub actual_passed { return @{ $_[0]->{actual_passed} } if ref $_[0]->{actual_passed}; return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed}; } *actual_ok = \&actual_passed; =head3 C This method is a synonym for C. =head3 C # the test numbers which actually failed my @actual_failed = $parser->actual_failed; # the number of tests which actually failed my $actual_failed = $parser->actual_failed; This method lets you know which (or how many) tests actually failed, regardless of whether or not a TODO directive was found. =cut sub actual_failed { @{ shift->{actual_failed} } } ############################################################################## =head3 C my @todo = $parser->todo; # the test numbers with todo directives my $todo = $parser->todo; # the number of tests with todo directives This method lets you know which (or how many) tests had TODO directives. =cut sub todo { @{ shift->{todo} } } =head3 C # the test numbers which unexpectedly succeeded my @todo_passed = $parser->todo_passed; # the number of tests which unexpectedly succeeded my $todo_passed = $parser->todo_passed; This method lets you know which (or how many) tests actually passed but were declared as "TODO" tests. =cut sub todo_passed { @{ shift->{todo_passed} } } ############################################################################## =head3 C # deprecated in favor of 'todo_passed'. This method was horribly misnamed. This was a badly misnamed method. It indicates which TODO tests unexpectedly succeeded. Will now issue a warning and call C. =cut sub todo_failed { warn '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; goto &todo_passed; } =head3 C my @skipped = $parser->skipped; # the test numbers with SKIP directives my $skipped = $parser->skipped; # the number of tests with SKIP directives This method lets you know which (or how many) tests had SKIP directives. =cut sub skipped { @{ shift->{skipped} } } =head2 Pragmas =head3 C Get or set a pragma. To get the state of a pragma: if ( $p->pragma('strict') ) { # be strict } To set the state of a pragma: $p->pragma('strict', 1); # enable strict mode =cut sub pragma { my ( $self, $pragma ) = splice @_, 0, 2; return $self->{pragma}->{$pragma} unless @_; if ( my $state = shift ) { $self->{pragma}->{$pragma} = 1; } else { delete $self->{pragma}->{$pragma}; } return; } =head3 C Get a list of all the currently enabled pragmas: my @pragmas_enabled = $p->pragmas; =cut sub pragmas { sort keys %{ shift->{pragma} || {} } } =head2 Summary Results These results are "meta" information about the total results of an individual test program. =head3 C my $plan = $parser->plan; Returns the test plan, if found. =head3 C Deprecated. Use C instead. =cut sub good_plan { warn 'good_plan() is deprecated. Please use "is_good_plan()"'; goto &is_good_plan; } ############################################################################## =head3 C if ( $parser->is_good_plan ) { ... } Returns a boolean value indicating whether or not the number of tests planned matches the number of tests run. B this was formerly C. The latter method is deprecated and will issue a warning. And since we're on that subject ... =head3 C print $parser->tests_planned; Returns the number of tests planned, according to the plan. For example, a plan of '1..17' will mean that 17 tests were planned. =head3 C print $parser->tests_run; Returns the number of tests which actually were run. Hopefully this will match the number of C<< $parser->tests_planned >>. =head3 C Returns a true value (actually the reason for skipping) if all tests were skipped. =head3 C Returns the wall-clock time when the Parser was created. =head3 C Returns the wall-clock time when the end of TAP input was seen. =head3 C Returns the CPU times (like L when the Parser was created. =head3 C Returns the CPU times (like L when the end of TAP input was seen. =head3 C if ( $parser->has_problems ) { ... } This is a 'catch-all' method which returns true if any tests have currently failed, any TODO tests unexpectedly succeeded, or any parse errors occurred. =cut sub has_problems { my $self = shift; return $self->failed || $self->parse_errors || ( !$self->ignore_exit && ( $self->wait || $self->exit ) ); } =head3 C $parser->version; Once the parser is done, this will return the version number for the parsed TAP. Version numbers were introduced with TAP version 13 so if no version number is found version 12 is assumed. =head3 C $parser->exit; Once the parser is done, this will return the exit status. If the parser ran an executable, it returns the exit status of the executable. =head3 C $parser->wait; Once the parser is done, this will return the wait status. If the parser ran an executable, it returns the wait status of the executable. Otherwise, this merely returns the C status. =head2 C $parser->ignore_exit(1); Tell the parser to ignore the exit status from the test when determining whether the test passed. Normally tests with non-zero exit status are considered to have failed even if all individual tests passed. In cases where it is not possible to control the exit value of the test script use this option to ignore it. =cut sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) } =head3 C my @errors = $parser->parse_errors; # the parser errors my $errors = $parser->parse_errors; # the number of parser_errors Fortunately, all TAP output is perfect. In the event that it is not, this method will return parser errors. Note that a junk line which the parser does not recognize is C an error. This allows this parser to handle future versions of TAP. The following are all TAP errors reported by the parser: =over 4 =item * Misplaced plan The plan (for example, '1..5'), must only come at the beginning or end of the TAP output. =item * No plan Gotta have a plan! =item * More than one plan 1..3 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 3 read the rest of the file 1..3 Right. Very funny. Don't do that. =item * Test numbers out of sequence 1..3 ok 1 - input file opened not ok 2 - first line of the input valid # todo some data ok 2 read the rest of the file That last test line above should have the number '3' instead of '2'. Note that it's perfectly acceptable for some lines to have test numbers and others to not have them. However, when a test number is found, it must be in sequence. The following is also an error: 1..3 ok 1 - input file opened not ok - first line of the input valid # todo some data ok 2 read the rest of the file But this is not: 1..3 ok - input file opened not ok - first line of the input valid # todo some data ok 3 read the rest of the file =back =cut sub parse_errors { @{ shift->{parse_errors} } } sub _add_error { my ( $self, $error ) = @_; push @{ $self->{parse_errors} } => $error; return $self; } sub _make_state_table { my $self = shift; my %states; my %planned_todo = (); # These transitions are defaults for all states my %state_globals = ( comment => {}, bailout => {}, yaml => {}, version => { act => sub { $self->_add_error( 'If TAP version is present it must be the first line of output' ); }, }, unknown => { act => sub { my $unk = shift; if ( $self->pragma('strict') ) { $self->_add_error( 'Unknown TAP token: "' . $unk->raw . '"' ); } }, }, pragma => { act => sub { my ($pragma) = @_; for my $pr ( $pragma->pragmas ) { if ( $pr =~ /^ ([-+])(\w+) $/x ) { $self->pragma( $2, $1 eq '+' ); } } }, }, ); # Provides default elements for transitions my %state_defaults = ( plan => { act => sub { my ($plan) = @_; $self->tests_planned( $plan->tests_planned ); $self->plan( $plan->plan ); if ( $plan->has_skip ) { $self->skip_all( $plan->explanation || '(no reason given)' ); } $planned_todo{$_}++ for @{ $plan->todo_list }; }, }, test => { act => sub { my ($test) = @_; my ( $number, $tests_run ) = ( $test->number, ++$self->{tests_run} ); # Fake TODO state if ( defined $number && delete $planned_todo{$number} ) { $test->set_directive('TODO'); } my $has_todo = $test->has_todo; $self->in_todo($has_todo); if ( defined( my $tests_planned = $self->tests_planned ) ) { if ( $tests_run > $tests_planned ) { $test->is_unplanned(1); } } if ( defined $number ) { if ( $number != $tests_run ) { my $count = $tests_run; $self->_add_error( "Tests out of sequence. Found " . "($number) but expected ($count)" ); } } else { $test->_number( $number = $tests_run ); } push @{ $self->{todo} } => $number if $has_todo; push @{ $self->{todo_passed} } => $number if $test->todo_passed; push @{ $self->{skipped} } => $number if $test->has_skip; push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } => $number; push @{ $self->{ $test->is_actual_ok ? 'actual_passed' : 'actual_failed' } } => $number; }, }, yaml => { act => sub { }, }, ); # Each state contains a hash the keys of which match a token type. For # each token # type there may be: # act A coderef to run # goto The new state to move to. Stay in this state if # missing # continue Goto the new state and run the new state for the # current token %states = ( INIT => { version => { act => sub { my ($version) = @_; my $ver_num = $version->version; if ( $ver_num <= $DEFAULT_TAP_VERSION ) { my $ver_min = $DEFAULT_TAP_VERSION + 1; $self->_add_error( "Explicit TAP version must be at least " . "$ver_min. Got version $ver_num" ); $ver_num = $DEFAULT_TAP_VERSION; } if ( $ver_num > $MAX_TAP_VERSION ) { $self->_add_error( "TAP specified version $ver_num but " . "we don't know about versions later " . "than $MAX_TAP_VERSION" ); $ver_num = $MAX_TAP_VERSION; } $self->version($ver_num); $self->_grammar->set_version($ver_num); }, goto => 'PLAN' }, plan => { goto => 'PLANNED' }, test => { goto => 'UNPLANNED' }, }, PLAN => { plan => { goto => 'PLANNED' }, test => { goto => 'UNPLANNED' }, }, PLANNED => { test => { goto => 'PLANNED_AFTER_TEST' }, plan => { act => sub { my ($version) = @_; $self->_add_error( 'More than one plan found in TAP output'); }, }, }, PLANNED_AFTER_TEST => { test => { goto => 'PLANNED_AFTER_TEST' }, plan => { act => sub { }, continue => 'PLANNED' }, yaml => { goto => 'PLANNED' }, }, GOT_PLAN => { test => { act => sub { my ($plan) = @_; my $line = $self->plan; $self->_add_error( "Plan ($line) must be at the beginning " . "or end of the TAP output" ); $self->is_good_plan(0); }, continue => 'PLANNED' }, plan => { continue => 'PLANNED' }, }, UNPLANNED => { test => { goto => 'UNPLANNED_AFTER_TEST' }, plan => { goto => 'GOT_PLAN' }, }, UNPLANNED_AFTER_TEST => { test => { act => sub { }, continue => 'UNPLANNED' }, plan => { act => sub { }, continue => 'UNPLANNED' }, yaml => { goto => 'UNPLANNED' }, }, ); # Apply globals and defaults to state table for my $name ( keys %states ) { # Merge with globals my $st = { %state_globals, %{ $states{$name} } }; # Add defaults for my $next ( sort keys %{$st} ) { if ( my $default = $state_defaults{$next} ) { for my $def ( sort keys %{$default} ) { $st->{$next}->{$def} ||= $default->{$def}; } } } # Stuff back in table $states{$name} = $st; } return \%states; } =head3 C Get an a list of file handles which can be passed to C 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.48/lib/Test/0000755000175000017500000000000014506607710014507 5ustar leontleontTest-Harness-3.48/lib/Test/Harness.pm0000644000175000017500000004041114506605636016455 0ustar leontleontpackage 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.48 =cut our $VERSION = '3.48'; # 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(); local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC}; _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}++; } } ); } ); local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC}; _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 separated 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.48/lib/App/0000755000175000017500000000000014506607710014310 5ustar leontleontTest-Harness-3.48/lib/App/Prove.pm0000644000175000017500000004435714506605636015763 0ustar leontleontpackage App::Prove; use strict; use warnings; use TAP::Harness::Env; use Text::ParseWords qw(shellwords); use File::Spec; use Getopt::Long; use App::Prove::State; use Carp; use base 'TAP::Object'; =head1 NAME App::Prove - Implements the C command. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =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 statefile ); __PACKAGE__->mk_methods(@ATTR); } =head1 METHODS =head2 Class Methods =head3 C Create a new C. Optionally a hash ref of attribute initializers may be passed. =cut # new() implementation supplied by TAP::Object sub _initialize { my $self = shift; my $args = shift || {}; my @is_array = qw( argv rc_opts includes modules state plugins rules sources ); # setup defaults: for my $key (@is_array) { $self->{$key} = []; } for my $attr (@ATTR) { if ( exists $args->{$attr} ) { # TODO: Some validation here $self->{$attr} = $args->{$attr}; } } $self->state_class('App::Prove::State'); return $self; } =head3 C Getter/setter for the name of the class used for maintaining state. This class should either subclass from C or provide an identical interface. =head3 C Getter/setter for the instance of the C. =cut =head3 C $prove->add_rc_file('myproj/.proverc'); Called before C to prepend the contents of an rc file to the options. =cut sub add_rc_file { my ( $self, $rc_file ) = @_; local *RC; open RC, "<$rc_file" or croak "Can't read $rc_file ($!)"; while ( defined( my $line = ) ) { push @{ $self->{rc_opts} }, grep { defined and not /^#/ } $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg; } close RC; } =head3 C $prove->process_args(@args); Processes the command-line arguments. Attributes will be set appropriately. Any filenames may be found in the C attribute. Dies on invalid arguments. =cut sub process_args { my $self = shift; my @rc = RC_FILE; unshift @rc, glob '~/' . RC_FILE if IS_UNIXY; # Preprocess meta-args. my @args; while ( defined( my $arg = shift ) ) { if ( $arg eq '--norc' ) { @rc = (); } elsif ( $arg eq '--rc' ) { defined( my $rc = shift ) or croak "Missing argument to --rc"; push @rc, $rc; } elsif ( $arg =~ m{^--rc=(.+)$} ) { push @rc, $1; } else { push @args, $arg; } } # Everything after the arisdottle '::' gets passed as args to # test programs. if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) { my @test_args = splice @args, $stop_at; shift @test_args; $self->{test_args} = \@test_args; } # Grab options from RC files $self->add_rc_file($_) for grep -f, @rc; unshift @args, @{ $self->{rc_opts} }; if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) { die "Long options should be written with two dashes: ", join( ', ', @bad ), "\n"; } # And finally... { local @ARGV = @args; Getopt::Long::Configure(qw(no_ignore_case bundling pass_through)); # Don't add coderefs to GetOptions GetOptions( 'v|verbose' => \$self->{verbose}, 'f|failures' => \$self->{failures}, 'o|comments' => \$self->{comments}, 'l|lib' => \$self->{lib}, 'b|blib' => \$self->{blib}, 's|shuffle' => \$self->{shuffle}, 'color!' => \$self->{color}, 'colour!' => \$self->{color}, 'count!' => \$self->{show_count}, 'c' => \$self->{color}, 'D|dry' => \$self->{dry}, 'ext=s@' => sub { my ( $opt, $val ) = @_; # Workaround for Getopt::Long 2.25 handling of # multivalue options push @{ $self->{extensions} ||= [] }, $val; }, 'harness=s' => \$self->{harness}, 'ignore-exit' => \$self->{ignore_exit}, 'source=s@' => $self->{sources}, 'formatter=s' => \$self->{formatter}, 'r|recurse' => \$self->{recurse}, 'reverse' => \$self->{backwards}, 'p|parse' => \$self->{parse}, 'q|quiet' => \$self->{quiet}, 'Q|QUIET' => \$self->{really_quiet}, 'e|exec=s' => \$self->{exec}, 'm|merge' => \$self->{merge}, 'I=s@' => $self->{includes}, 'M=s@' => $self->{modules}, 'P=s@' => $self->{plugins}, 'state=s@' => $self->{state}, 'statefile=s' => \$self->{statefile}, '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}; } 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 = map { $self->$_() ? $verb_map{$_} : () } 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 if @verb_adj; for my $a (qw( merge failures comments timer directives normalize )) { $args{$a} = 1 if $self->$a(); } $args{errors} = 1 if $self->parse; # defined but zero-length exec runs test files as binaries $args{exec} = [ split( /\s+/, $self->exec ) ] if ( defined( $self->exec ) ); $args{version} = $self->tapversion if defined( $self->tapversion ); if ( defined( my $test_args = $self->test_args ) ) { $args{test_args} = $test_args; } if ( @{ $self->rules } ) { my @rules; for ( @{ $self->rules } ) { if (/^par=(.*)/) { push @rules, $1; } elsif (/^seq=(.*)/) { push @rules, { seq => $1 }; } } $args{rules} = { par => [@rules] }; } $args{harness_class} = $self->{harness_class} if $self->{harness_class}; return \%args; } sub _find_module { my ( $self, $class, @search ) = @_; croak "Bad module name $class" unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; for my $pfx (@search) { my $name = join( '::', $pfx, $class ); eval "require $name"; return $name unless $@; } eval "require $class"; return $class unless $@; return; } sub _load_extension { my ( $self, $name, @search ) = @_; my @args = (); if ( $name =~ /^(.*?)=(.*)/ ) { $name = $1; @args = split( /,/, $2 ); } if ( my $class = $self->_find_module( $name, @search ) ) { 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 => $self->statefile || STATE_FILE } ) ); } if ( $self->show_help ) { $self->_help(1); } elsif ( $self->show_man ) { $self->_help(2); } elsif ( $self->show_version ) { $self->print_version; } elsif ( $self->dry ) { print "$_\n" for $self->_get_tests; } else { $self->_load_extensions( $self->modules ); $self->_load_extensions( $self->plugins, PLUGINS ); local $ENV{TEST_VERBOSE} = 1 if $self->verbose; return $self->_runtests( $self->_get_args, $self->_get_tests ); } return 1; } sub _get_tests { my $self = shift; my $state = $self->state_manager; my $ext = $self->extensions; $state->extensions($ext) if defined $ext; if ( defined( my $state_switch = $self->state ) ) { $state->apply_switch(@$state_switch); } my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); $self->_shuffle(@tests) if $self->shuffle; @tests = reverse @tests if $self->backwards; return @tests; } sub _runtests { my ( $self, $args, @tests ) = @_; my $harness = TAP::Harness::Env->create($args); my $state = $self->state_manager; $harness->callback( after_test => sub { $state->observe_test(@_); } ); $harness->callback( after_runtests => sub { $state->commit(@_); } ); my $aggregator = $harness->runtests(@tests); return !$aggregator->has_errors; } sub _get_switches { my $self = shift; my @switches; # notes that -T or -t must be at the front of the switches! if ( $self->taint_fail ) { push @switches, '-T'; } elsif ( $self->taint_warn ) { push @switches, '-t'; } if ( $self->warnings_fail ) { push @switches, '-W'; } elsif ( $self->warnings_warn ) { push @switches, '-w'; } return @switches ? \@switches : (); } sub _get_lib { my $self = shift; my @libs; if ( $self->lib ) { push @libs, 'lib'; } if ( $self->blib ) { push @libs, 'blib/lib', 'blib/arch'; } if ( @{ $self->includes } ) { push @libs, @{ $self->includes }; } #24926 @libs = map { File::Spec->rel2abs($_) } @libs; # Huh? return @libs ? \@libs : (); } sub _shuffle { my $self = shift; # Fisher-Yates shuffle my $i = @_; while ($i) { my $j = rand $i--; @_[ $i, $j ] = @_[ $j, $i ]; } return; } =head3 C Load a harness replacement class. $prove->require_harness($for => $class_name); =cut sub require_harness { my ( $self, $for, $class ) = @_; my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/; # Emulate Perl's -MModule=arg1,arg2 behaviour $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!; eval("use $class;"); die "$class_name is required to use the --$for feature: $@" if $@; $self->{harness_class} = $class_name; return; } =head3 C Display the version numbers of the loaded L and the current Perl. =cut sub print_version { my $self = shift; require TAP::Harness; printf( "TAP::Harness v%s and Perl v%vd\n", $TAP::Harness::VERSION, $^V ); return; } 1; # vim:ts=4:sw=4:et:sta __END__ =head2 Attributes After command line parsing the following attributes reflect the values of the corresponding command line switches. They may be altered before calling C. =over =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =back =head1 PLUGINS C provides support for 3rd-party plugins. These are currently loaded at run-time, I arguments have been parsed (so you can not change the way arguments are processed, sorry), typically with the C<< -PI >> switch, eg: prove -PMyPlugin This will search for a module named C, or failing that, C. If the plugin can't be found, C will complain & exit. You can pass an argument to your plugin by appending an C<=> after the plugin name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas: prove -PMyPlugin=foo,bar,baz These are passed in to your plugin's C class method (if it has one), along with a reference to the C object that is invoking your plugin: sub load { my ($class, $p) = @_; my @args = @{ $p->{args} }; # @args will contain ( 'foo', 'bar', 'baz' ) $p->{app_prove}->do_something; ... } =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.48/lib/App/Prove/0000755000175000017500000000000014506607710015403 5ustar leontleontTest-Harness-3.48/lib/App/Prove/State/0000755000175000017500000000000014506607710016463 5ustar leontleontTest-Harness-3.48/lib/App/Prove/State/Result/0000755000175000017500000000000014506607710017741 5ustar leontleontTest-Harness-3.48/lib/App/Prove/State/Result/Test.pm0000644000175000017500000000653214506605636021231 0ustar leontleontpackage App::Prove::State::Result::Test; use strict; use warnings; =head1 NAME App::Prove::State::Result::Test - Individual test results. =head1 VERSION Version 3.48 =cut our $VERSION = '3.48'; =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.48/lib/App/Prove/State/Result.pm0000644000175000017500000001152114506605636020304 0ustar leontleontpackage 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.48 =cut our $VERSION = '3.48'; =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.48/lib/App/Prove/State.pm0000644000175000017500000002665114506605636017040 0ustar leontleontpackage 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.48 =cut our $VERSION = '3.48'; =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.48/Changes-2.640000644000175000017500000006545112166360606014717 0ustar leontleontRevision 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.48/HACKING.pod0000644000175000017500000001431214424057335014574 0ustar leontleont # 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