diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-10-02 15:57:26 +0100 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-10-02 15:57:26 +0100 |
| commit | b8a2040150d386de90994afd87f9d01bd861104a (patch) | |
| tree | 9418ac04b77045e3bb187954c5fbf873557f7474 /ext | |
| parent | 8d4ff56f76907d1619ddc5fd7040d3823057ec47 (diff) | |
| download | perl-b8a2040150d386de90994afd87f9d01bd861104a.tar.gz | |
Move Test::Harness from ext/ to cpan/
Diffstat (limited to 'ext')
180 files changed, 0 insertions, 27371 deletions
diff --git a/ext/Test-Harness/Changes b/ext/Test-Harness/Changes deleted file mode 100644 index 6141f78f36..0000000000 --- a/ext/Test-Harness/Changes +++ /dev/null @@ -1,682 +0,0 @@ -Revision history for Test-Harness - -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 - <link@redbrick.dcu.ie> 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 ... diff --git a/ext/Test-Harness/bin/prove b/ext/Test-Harness/bin/prove deleted file mode 100644 index a592a80f0d..0000000000 --- a/ext/Test-Harness/bin/prove +++ /dev/null @@ -1,305 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use App::Prove; - -my $app = App::Prove->new; -$app->process_args(@ARGV); -exit( $app->run ? 0 : 1 ); - -__END__ - -=head1 NAME - -prove - Run tests through a TAP harness. - -=head1 USAGE - - prove [options] [files or directories] - -=head1 OPTIONS - -Boolean options: - - -v, --verbose Print all test lines. - -l, --lib Add 'lib' to the path for your tests (-Ilib). - -b, --blib Add 'blib/lib' and 'blib/arch' to the path for your tests - -s, --shuffle Run the tests in random order. - -c, --color Colored test output (default). - --nocolor Do not color test output. - --count Show the X/Y test count when not verbose (default) - --nocount Disable the X/Y test count. - -D --dry Dry run. Show test that would have run. - --ext Set the extension for tests (default '.t') - -f, --failures Show failed tests. - -o, --comments Show comments. - --fork Fork to run harness in multiple processes. - --ignore-exit Ignore exit status from test scripts. - -m, --merge Merge test scripts' STDERR with their STDOUT. - -r, --recurse Recursively descend into directories. - --reverse Run the tests in reverse order. - -q, --quiet Suppress some test output while running tests. - -Q, --QUIET Only print summary results. - -p, --parse Show full list of TAP parse errors, if any. - --directives Only show results with TODO or SKIP directives. - --timer Print elapsed time after each test. - --normalize Normalize TAP output in verbose output - -T Enable tainting checks. - -t Enable tainting warnings. - -W Enable fatal warnings. - -w Enable warnings. - -h, --help Display this help - -?, Display this help - -H, --man Longer manpage for prove - --norc Don't process default .proverc - -Options that take arguments: - - -I Library paths to include. - -P Load plugin (searches App::Prove::Plugin::*.) - -M Load a module. - -e, --exec Interpreter to run the tests ('' for compiled tests.) - --harness Define test harness to use. See TAP::Harness. - --formatter Result formatter to use. See TAP::Harness. - -a, --archive Store the resulting TAP in an archive file. - -j, --jobs N Run N test jobs in parallel (try 9.) - --state=opts Control prove's persistent state. - --rc=rcfile Process options from rcfile - -=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 --fork - -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<STDIN> - -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<README> in the C<examples> directory of this distribution. - -=head2 Default Test Directory - -If no files or directories are supplied, C<prove> looks for all files -matching the pattern C<t/*.t>. - -=head2 Colored Test Output - -Colored test output is the default, but if output is not to a -terminal, color is disabled. You can override this by adding the -C<--color> switch. - -Color support requires L<Term::ANSIColor> on Unix-like platforms and -L<Win32::Console> windows. If the necessary module is not installed -colored output will not be available. - -=head2 Exit Code - -If the tests fail C<prove> 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<t/mytest.t> 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 STDOUT -(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<--state> - -You can ask C<prove> 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<last> - -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<failed> - -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<save> option newly passing tests will be -excluded from subsequent runs. - - # Repeat until no more failures - $ prove -b --state=failed,save - -=item C<passed> - -Run only the passed tests from last time. Useful to make sure that no -new problems have been introduced. - -=item C<all> - -Run all tests in normal order. Multple options may be specified, so to -run all tests with the failures from last time first: - - $ prove -b --state=failed,all,save - -=item C<hot> - -Run the tests that most recently failed first. The last failure time of -each test is stored. The C<hot> 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<todo> - -Run any tests with todos. - -=item C<slow> - -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<fast> - -Run test tests in fastest to slowest order. - -=item C<new> - -Run the tests in newest to oldest order based on the modification times -of the test scripts. - -=item C<old> - -Run the tests in oldest to newest order. - -=item C<fresh> - -Run those test scripts that have been modified since the last test run. - -=item C<save> - -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 @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<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or -via the C<-Ilib> option to F<prove>. - -=head2 Taint Mode - -Normally when a Perl program is run in taint mode the contents of the -C<PERL5LIB> environment variable do not appear in C<@INC>. - -Because C<PERL5LIB> is often used during testing to add build directories -to C<@INC> prove (actually L<TAP::Parser::Source::Perl>) passes the -names of any directories found in C<PERL5LIB> as -I switches. The net -effect of this is that C<PERL5LIB> is honoured even when prove is run in -taint mode. - -=head1 PLUGINS - -Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg: - - prove -PMyPlugin - -This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing -that, C<MyPlugin>. If the plugin can't be found, C<prove> 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<http://search.cpan.org/search?query=App%3A%3AProve+Plugin> - -=head2 Writing Plugins - -Please see L<App::Prove/PLUGINS>. - -=cut - -# vim:ts=4:sw=4:et:sta diff --git a/ext/Test-Harness/lib/App/Prove.pm b/ext/Test-Harness/lib/App/Prove.pm deleted file mode 100644 index fd431ed2f0..0000000000 --- a/ext/Test-Harness/lib/App/Prove.pm +++ /dev/null @@ -1,774 +0,0 @@ -package App::Prove; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); -use TAP::Harness; -use TAP::Parser::Utils qw( split_shell ); -use File::Spec; -use Getopt::Long; -use App::Prove::State; -use Carp; - -=head1 NAME - -App::Prove - Implements the C<prove> command. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -L<Test::Harness> provides a command, C<prove>, which runs a TAP based -test suite and prints a report. The C<prove> 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 { - @ISA = qw(TAP::Object); - - @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 extension ignore_exit rules state_manager - normalize - ); - __PACKAGE__->mk_methods(@ATTR); -} - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -Create a new C<App::Prove>. 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 || {}; - - # setup defaults: - for my $key (qw( argv rc_opts includes modules state plugins rules )) { - $self->{$key} = []; - } - $self->{harness_class} = 'TAP::Harness'; - - for my $attr (@ATTR) { - if ( exists $args->{$attr} ) { - - # TODO: Some validation here - $self->{$attr} = $args->{$attr}; - } - } - - my %env_provides_default = ( - HARNESS_TIMER => 'timer', - ); - - while ( my ( $env, $attr ) = each %env_provides_default ) { - $self->{$attr} = 1 if $ENV{$env}; - } - $self->state_class('App::Prove::State'); - return $self; -} - -=head3 C<state_class> - -Getter/setter for the name of the class used for maintaining state. This -class should either subclass from C<App::Prove::State> or provide an identical -interface. - -=head3 C<state_manager> - -Getter/setter for the instance of the C<state_class>. - -=cut - -=head3 C<add_rc_file> - - $prove->add_rc_file('myproj/.proverc'); - -Called before C<process_args> 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 = <RC> ) ) { - push @{ $self->{rc_opts} }, - grep { defined and not /^#/ } - $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg; - } - close RC; -} - -=head3 C<process_args> - - $prove->process_args(@args); - -Processes the command-line arguments. Attributes will be set -appropriately. Any filenames may be found in the C<argv> 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( 'no_ignore_case', 'bundling' ); - - # 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' => \$self->{extension}, - 'harness=s' => \$self->{harness}, - 'ignore-exit' => \$self->{ignore_exit}, - 'formatter=s' => \$self->{formatter}, - 'r|recurse' => \$self->{recurse}, - 'reverse' => \$self->{backwards}, - 'p|parse' => \$self->{parse}, - 'q|quiet' => \$self->{quiet}, - 'Q|QUIET' => \$self->{really_quiet}, - 'e|exec=s' => \$self->{exec}, - 'm|merge' => \$self->{merge}, - 'I=s@' => $self->{includes}, - 'M=s@' => $self->{modules}, - 'P=s@' => $self->{plugins}, - 'state=s@' => $self->{state}, - 'directives' => \$self->{directives}, - 'h|help|?' => \$self->{show_help}, - 'H|man' => \$self->{show_man}, - 'V|version' => \$self->{show_version}, - 'a|archive=s' => \$self->{archive}, - 'j|jobs=i' => \$self->{jobs}, - 'timer' => \$self->{timer}, - 'T' => \$self->{taint_fail}, - 't' => \$self->{taint_warn}, - 'W' => \$self->{warnings_fail}, - 'w' => \$self->{warnings_warn}, - 'normalize' => \$self->{normalize}, - 'rules=s@' => $self->{rules}, - ) or croak('Unable to continue'); - - # Stash the remainder of argv for later - $self->{argv} = [@ARGV]; - } - - return; -} - -sub _first_pos { - my $want = shift; - for ( 0 .. $#_ ) { - return $_ if $_[$_] eq $want; - } - return; -} - -sub _help { - my ( $self, $verbosity ) = @_; - - eval('use Pod::Usage 1.12 ()'); - if ( my $err = $@ ) { - die 'Please install Pod::Usage for the --help option ' - . '(or try `perldoc prove`.)' - . "\n ($@)"; - } - - Pod::Usage::pod2usage( { -verbose => $verbosity } ); - - return; -} - -sub _color_default { - my $self = shift; - - return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32; -} - -sub _get_args { - my $self = shift; - - my %args; - - 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; - } - - if ( $self->ignore_exit ) { - $args{ignore_exit} = 1; - } - - if ( $self->taint_fail && $self->taint_warn ) { - die '-t and -T are mutually exclusive'; - } - - if ( $self->warnings_fail && $self->warnings_warn ) { - die '-w and -W are mutually exclusive'; - } - - for my $a (qw( lib switches )) { - my $method = "_get_$a"; - my $val = $self->$method(); - $args{$a} = $val if defined $val; - } - - # Handle verbose, quiet, really_quiet flags - my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, ); - - my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 } - keys %verb_map; - - die "Only one of verbose, quiet or really_quiet should be specified\n" - if @verb_adj > 1; - - $args{verbosity} = shift @verb_adj || 0; - - for my $a (qw( merge failures comments timer directives normalize )) { - $args{$a} = 1 if $self->$a(); - } - - $args{errors} = 1 if $self->parse; - - # defined but zero-length exec runs test files as binaries - $args{exec} = [ split( /\s+/, $self->exec ) ] - if ( defined( $self->exec ) ); - - if ( defined( my $test_args = $self->test_args ) ) { - $args{test_args} = $test_args; - } - - if ( @{ $self->rules } ) { - my @rules; - for ( @{ $self->rules } ) { - if (/^par=(.*)/) { - push @rules, $1; - } - elsif (/^seq=(.*)/) { - push @rules, { seq => $1 }; - } - } - $args{rules} = { par => [@rules] }; - } - - return ( \%args, $self->{harness_class} ); -} - -sub _find_module { - my ( $self, $class, @search ) = @_; - - croak "Bad module name $class" - unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; - - for my $pfx (@search) { - my $name = join( '::', $pfx, $class ); - eval "require $name"; - return $name unless $@; - } - - eval "require $class"; - return $class unless $@; - return; -} - -sub _load_extension { - my ( $self, $name, @search ) = @_; - - my @args = (); - if ( $name =~ /^(.*?)=(.*)/ ) { - $name = $1; - @args = split( /,/, $2 ); - } - - if ( my $class = $self->_find_module( $name, @search ) ) { - $class->import(@args); - if ( $class->can('load') ) { - $class->load( { app_prove => $self, args => [@args] } ); - } - } - else { - croak "Can't load module $name"; - } -} - -sub _load_extensions { - my ( $self, $ext, @search ) = @_; - $self->_load_extension( $_, @search ) for @$ext; -} - -=head3 C<run> - -Perform whatever actions the command line args specified. The C<prove> -command line tool consists of the following code: - - use App::Prove; - - my $app = App::Prove->new; - $app->process_args(@ARGV); - exit( $app->run ? 0 : 1 ); # if you need the exit code - -=cut - -sub run { - my $self = shift; - - unless ( $self->state_manager ) { - $self->state_manager( - $self->state_class->new( { store => STATE_FILE } ) ); - } - - if ( $self->show_help ) { - $self->_help(1); - } - elsif ( $self->show_man ) { - $self->_help(2); - } - elsif ( $self->show_version ) { - $self->print_version; - } - elsif ( $self->dry ) { - print "$_\n" for $self->_get_tests; - } - else { - - $self->_load_extensions( $self->modules ); - $self->_load_extensions( $self->plugins, PLUGINS ); - - local $ENV{TEST_VERBOSE} = 1 if $self->verbose; - - return $self->_runtests( $self->_get_args, $self->_get_tests ); - } - - return 1; -} - -sub _get_tests { - my $self = shift; - - my $state = $self->state_manager; - my $ext = $self->extension; - $state->extension($ext) if defined $ext; - if ( defined( my $state_switch = $self->state ) ) { - $state->apply_switch(@$state_switch); - } - - my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); - - $self->_shuffle(@tests) if $self->shuffle; - @tests = reverse @tests if $self->backwards; - - return @tests; -} - -sub _runtests { - my ( $self, $args, $harness_class, @tests ) = @_; - my $harness = $harness_class->new($args); - - my $state = $self->state_manager; - - $harness->callback( - after_test => sub { - $state->observe_test(@_); - } - ); - - $harness->callback( - after_runtests => sub { - $state->commit(@_); - } - ); - - my $aggregator = $harness->runtests(@tests); - - return !$aggregator->has_errors; -} - -sub _get_switches { - my $self = shift; - my @switches; - - # notes that -T or -t must be at the front of the switches! - if ( $self->taint_fail ) { - push @switches, '-T'; - } - elsif ( $self->taint_warn ) { - push @switches, '-t'; - } - if ( $self->warnings_fail ) { - push @switches, '-W'; - } - elsif ( $self->warnings_warn ) { - push @switches, '-w'; - } - - push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} ); - - return @switches ? \@switches : (); -} - -sub _get_lib { - my $self = shift; - my @libs; - if ( $self->lib ) { - push @libs, 'lib'; - } - if ( $self->blib ) { - push @libs, 'blib/lib', 'blib/arch'; - } - if ( @{ $self->includes } ) { - push @libs, @{ $self->includes }; - } - - #24926 - @libs = map { File::Spec->rel2abs($_) } @libs; - - # Huh? - return @libs ? \@libs : (); -} - -sub _shuffle { - my $self = shift; - - # Fisher-Yates shuffle - my $i = @_; - while ($i) { - my $j = rand $i--; - @_[ $i, $j ] = @_[ $j, $i ]; - } - return; -} - -=head3 C<require_harness> - -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<print_version> - -Display the version numbers of the loaded L<TAP::Harness> and the -current Perl. - -=cut - -sub print_version { - my $self = shift; - printf( - "TAP::Harness v%s and Perl v%vd\n", - $TAP::Harness::VERSION, $^V - ); - - return; -} - -1; - -# vim:ts=4:sw=4:et:sta - -__END__ - -=head2 Attributes - -After command line parsing the following attributes reflect the values -of the corresponding command line switches. They may be altered before -calling C<run>. - -=over - -=item C<archive> - -=item C<argv> - -=item C<backwards> - -=item C<blib> - -=item C<color> - -=item C<directives> - -=item C<dry> - -=item C<exec> - -=item C<extension> - -=item C<failures> - -=item C<comments> - -=item C<formatter> - -=item C<harness> - -=item C<ignore_exit> - -=item C<includes> - -=item C<jobs> - -=item C<lib> - -=item C<merge> - -=item C<modules> - -=item C<parse> - -=item C<plugins> - -=item C<quiet> - -=item C<really_quiet> - -=item C<recurse> - -=item C<rules> - -=item C<show_count> - -=item C<show_help> - -=item C<show_man> - -=item C<show_version> - -=item C<shuffle> - -=item C<state> - -=item C<state_class> - -=item C<taint_fail> - -=item C<taint_warn> - -=item C<test_args> - -=item C<timer> - -=item C<verbose> - -=item C<warnings_fail> - -=item C<warnings_warn> - -=back - -=head1 PLUGINS - -C<App::Prove> provides support for 3rd-party plugins. These are currently -loaded at run-time, I<after> arguments have been parsed (so you can not -change the way arguments are processed, sorry), typically with the -C<< -PI<plugin> >> switch, eg: - - prove -PMyPlugin - -This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing -that, C<MyPlugin>. If the plugin can't be found, C<prove> 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<load()> class method (if it has one), -along with a reference to the C<App::Prove> object that is invoking your plugin: - - sub load { - my ($class, $p) = @_; - - my @args = @{ $p->{args} }; - # @args will contain ( 'foo', 'bar', 'baz' ) - $p->{app_prove}->do_something; - ... - } - -Note that the user's arguments are also passed to your plugin's C<import()> -function as a list, eg: - - sub import { - my ($class, @args) = @_; - # @args will contain ( 'foo', 'bar', 'baz' ) - ... - } - -This is for backwards compatibility, and may be deprecated in the future. - -=head2 Sample Plugin - -Here's a sample plugin, for your reference: - - package App::Prove::Plugin::Foo; - - # Sample plugin, try running with: - # prove -PFoo=bar -r -j3 - # prove -PFoo -Q - # prove -PFoo=bar,My::Formatter - - use strict; - use warnings; - - sub load { - my ($class, $p) = @_; - my @args = @{ $p->{args} }; - my $app = $p->{app_prove}; - - print "loading plugin: $class, args: ", join(', ', @args ), "\n"; - - # turn on verbosity - $app->verbose( 1 ); - - # set the formatter? - $app->formatter( $args[1] ) if @args > 1; - - # print some of App::Prove's state: - for my $attr (qw( jobs quiet really_quiet recurse verbose )) { - my $val = $app->$attr; - $val = 'undef' unless defined( $val ); - print "$attr: $val\n"; - } - - return 1; - } - - 1; - -=head1 SEE ALSO - -L<prove>, L<TAP::Harness> - -=cut diff --git a/ext/Test-Harness/lib/App/Prove/State.pm b/ext/Test-Harness/lib/App/Prove/State.pm deleted file mode 100644 index 202f7aadd3..0000000000 --- a/ext/Test-Harness/lib/App/Prove/State.pm +++ /dev/null @@ -1,517 +0,0 @@ -package App::Prove::State; - -use strict; -use vars qw($VERSION @ISA); - -use File::Find; -use File::Spec; -use Carp; - -use App::Prove::State::Result; -use TAP::Parser::YAMLish::Reader (); -use TAP::Parser::YAMLish::Writer (); -use TAP::Base; - -BEGIN { - @ISA = qw( TAP::Base ); - __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<prove> command. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -The C<prove> 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=fail,save -rbv - -=cut - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -Accepts a hashref with the following key/value pairs: - -=over 4 - -=item * C<store> - -The filename of the data store holding the data that App::Prove::State reads. - -=item * C<extension> (optional) - -The test name extension. Defaults to C<.t>. - -=item * C<result_class> (optional) - -The name of the C<result_class>. Defaults to C<App::Prove::State::Result>. - -=back - -=cut - -# override TAP::Base::new: -sub new { - my $class = shift; - my %args = %{ shift || {} }; - - my $self = bless { - select => [], - seq => 1, - store => delete $args{store}, - extension => ( delete $args{extension} || '.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<result_class> - -Getter/setter for the name of the class used for tracking test results. This -class should either subclass from C<App::Prove::State::Result> or provide an -identical interface. - -=cut - -=head2 C<extension> - -Get or set the extension files must have in order to be considered -tests. Defaults to '.t'. - -=cut - -sub extension { - my $self = shift; - $self->{extension} = shift if @_; - return $self->{extension}; -} - -=head2 C<results> - -Get the results of the last test run. Returns a C<result_class()> instance. - -=cut - -sub results { - my $self = shift; - $self->{_} || $self->result_class->new; -} - -=head2 C<commit> - -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<apply_switch> - - $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<last> - -Run in the same order as last time - -=item C<failed> - -Run only the failed tests from last time - -=item C<passed> - -Run only the passed tests from last time - -=item C<all> - -Run all tests in normal order - -=item C<hot> - -Run the tests that most recently failed first - -=item C<todo> - -Run the tests ordered by number of todos. - -=item C<slow> - -Run the tests in slowest to fastest order. - -=item C<fast> - -Run test tests in fastest to slowest order. - -=item C<new> - -Run the tests in newest to oldest order. - -=item C<old> - -Run the tests in oldest to newest order. - -=item C<save> - -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( - where => sub { $_->generation >= $last_gen }, - order => sub { $_->sequence } - ); - }, - failed => sub { - $self->_select( - where => sub { $_->result != 0 }, - order => sub { -$_->result } - ); - }, - passed => sub { - $self->_select( where => sub { $_->result == 0 } ); - }, - all => sub { - $self->_select(); - }, - todo => sub { - $self->_select( - where => sub { $_->num_todo != 0 }, - order => sub { -$_->num_todo; } - ); - }, - hot => sub { - $self->_select( - where => sub { defined $_->last_fail_time }, - order => sub { $now - $_->last_fail_time } - ); - }, - slow => sub { - $self->_select( order => sub { -$_->elapsed } ); - }, - fast => sub { - $self->_select( order => sub { $_->elapsed } ); - }, - new => sub { - $self->_select( order => sub { -$_->mtime } ); - }, - old => sub { - $self->_select( order => sub { $_->mtime } ); - }, - fresh => sub { - $self->_select( 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<get_tests> - -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; - } - - return @got; -} - -sub _get_raw_tests { - my $self = shift; - my $recurse = shift; - my @argv = @_; - my @tests; - - # Do globbing on Win32. - @argv = map { glob "$_" } @argv if NEED_GLOB; - my $extension = $self->{extension}; - - for my $arg (@argv) { - if ( '-' eq $arg ) { - push @argv => <STDIN>; - chomp(@argv); - next; - } - - push @tests, - sort -d $arg - ? $recurse - ? $self->_expand_dir_recursive( $arg, $extension ) - : glob( File::Spec->catfile( $arg, "*$extension" ) ) - : $arg; - } - return @tests; -} - -sub _expand_dir_recursive { - my ( $self, $dir, $extension ) = @_; - - my @tests; - find( - { follow => 1, #21938 - follow_skip => 2, - wanted => sub { - -f - && /\Q$extension\E$/ - && push @tests => $File::Find::name; - } - }, - $dir - ); - return @tests; -} - -=head3 C<observe_test> - -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<save> - -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> - -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 = <FH>; - 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; diff --git a/ext/Test-Harness/lib/App/Prove/State/Result.pm b/ext/Test-Harness/lib/App/Prove/State/Result.pm deleted file mode 100644 index 274676a62f..0000000000 --- a/ext/Test-Harness/lib/App/Prove/State/Result.pm +++ /dev/null @@ -1,233 +0,0 @@ -package App::Prove::State::Result; - -use strict; -use Carp 'croak'; - -use App::Prove::State::Result::Test; -use vars qw($VERSION); - -use constant STATE_VERSION => 1; - -=head1 NAME - -App::Prove::State::Result - Individual test suite results. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -The C<prove> 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=fail,save -rbv - -=cut - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $result = App::Prove::State::Result->new({ - generation => $generation, - tests => \%tests, - }); - -Returns a new C<App::Prove::State::Result> 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<state_version> - -Returns the current version of state storage. - -=cut - -sub state_version {STATE_VERSION} - -=head2 C<test_class> - -Returns the name of the class used for tracking individual tests. This class -should either subclass from C<App::Prove::State::Result::Test> 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<generation> - -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<last_run_time> - -Getter/setter for the time of the test suite run. - -=head3 C<tests> - -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<test> - - my $test = $result->test('t/customer/create.t'); - -Returns an individual C<App::Prove::State::Result::Test> instance for the -given test name (usually the filename). Will return a new -C<App::Prove::State::Result::Test> 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<test_names> - -Returns an list of test names, sorted by run order. - -=cut - -sub test_names { - my $self = shift; - return map { $_->name } $self->tests; -} - -=head3 C<remove> - - $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<num_tests> - -Returns the number of tests for a given test suite result. - -=cut - -sub num_tests { keys %{ shift->{tests} } } - -=head3 C<raw> - -Returns a hashref of raw results, suitable for serialization by YAML. - -=cut - -sub raw { - my $self = shift; - my %raw = %$self; - - my %tests; - foreach my $test ( $self->tests ) { - $tests{ $test->name } = $test->raw; - } - $raw{tests} = \%tests; - return \%raw; -} - -1; diff --git a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm b/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm deleted file mode 100644 index 231f78919e..0000000000 --- a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm +++ /dev/null @@ -1,153 +0,0 @@ -package App::Prove::State::Result::Test; - -use strict; - -use vars qw($VERSION); - -=head1 NAME - -App::Prove::State::Result::Test - Individual test results. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -The C<prove> 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=fail,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<new> - -=cut - -sub new { - my ( $class, $arg_for ) = @_; - $arg_for ||= {}; - bless $arg_for => $class; -} - -=head2 Instance Methods - -=head3 C<name> - -The name of the test. Usually a filename. - -=head3 C<elapsed> - -The total elapsed times the test took to run, in seconds from the epoch.. - -=head3 C<generation> - -The number for the "generation" of the test run. The first generation is 1 -(one) and subsequent generations are 2, 3, etc. - -=head3 C<last_pass_time> - -The last time the test program passed, in seconds from the epoch. - -Returns C<undef> if the program has never passed. - -=head3 C<last_fail_time> - -The last time the test suite failed, in seconds from the epoch. - -Returns C<undef> if the program has never failed. - -=head3 C<mtime> - -Returns the mtime of the test, in seconds from the epoch. - -=head3 C<raw> - -Returns a hashref of raw test data, suitable for serialization by YAML. - -=head3 C<result> - -Currently, whether or not the test suite passed with no 'problems' (such as -TODO passed). - -=head3 C<run_time> - -The total time it took for the test to run, in seconds. If C<Time::HiRes> is -available, it will have finer granularity. - -=head3 C<num_todo> - -The number of tests with TODO directives. - -=head3 C<sequence> - -The order in which this test was run for the given test suite result. - -=head3 C<total_passes> - -The number of times the test has passed. - -=head3 C<total_failures> - -The number of times the test has failed. - -=head3 C<parser> - -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; diff --git a/ext/Test-Harness/lib/TAP/Base.pm b/ext/Test-Harness/lib/TAP/Base.pm deleted file mode 100644 index f88ad11134..0000000000 --- a/ext/Test-Harness/lib/TAP/Base.pm +++ /dev/null @@ -1,129 +0,0 @@ -package TAP::Base; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object; - -@ISA = qw(TAP::Object); - -=head1 NAME - -TAP::Base - Base class that provides common functionality to L<TAP::Parser> -and L<TAP::Harness> - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -use constant GOT_TIME_HIRES => do { - eval 'use Time::HiRes qw(time);'; - $@ ? 0 : 1; -}; - -=head1 SYNOPSIS - - package TAP::Whatever; - - use TAP::Base; - - use vars qw($VERSION @ISA); - @ISA = qw(TAP::Base); - - # ... later ... - - my $thing = TAP::Whatever->new(); - - $thing->callback( event => sub { - # do something interesting - } ); - -=head1 DESCRIPTION - -C<TAP::Base> provides callback management. - -=head1 METHODS - -=head2 Class Methods - -=cut - -sub _initialize { - my ( $self, $arg_for, $ok_callback ) = @_; - - my %ok_map = map { $_ => 1 } @$ok_callback; - - $self->{ok_callbacks} = \%ok_map; - - if ( my $cb = delete $arg_for->{callbacks} ) { - while ( my ( $event, $callback ) = each %$cb ) { - $self->callback( $event, $callback ); - } - } - - return $self; -} - -=head3 C<callback> - -Install a callback for a named event. - -=cut - -sub callback { - my ( $self, $event, $callback ) = @_; - - my %ok_map = %{ $self->{ok_callbacks} }; - - $self->_croak('No callbacks may be installed') - unless %ok_map; - - $self->_croak( "Callback $event is not supported. Valid callbacks are " - . join( ', ', sort keys %ok_map ) ) - unless exists $ok_map{$event}; - - push @{ $self->{code_for}{$event} }, $callback; - - return; -} - -sub _has_callbacks { - my $self = shift; - return keys %{ $self->{code_for} } != 0; -} - -sub _callback_for { - my ( $self, $event ) = @_; - return $self->{code_for}{$event}; -} - -sub _make_callback { - my $self = shift; - my $event = shift; - - my $cb = $self->_callback_for($event); - return unless defined $cb; - return map { $_->(@_) } @$cb; -} - -=head3 C<get_time> - -Return the current time using Time::HiRes if available. - -=cut - -sub get_time { return time() } - -=head3 C<time_is_hires> - -Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available). - -=cut - -sub time_is_hires { return GOT_TIME_HIRES } - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Base.pm b/ext/Test-Harness/lib/TAP/Formatter/Base.pm deleted file mode 100644 index f2b54a9ba3..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/Base.pm +++ /dev/null @@ -1,449 +0,0 @@ -package TAP::Formatter::Base; - -use strict; -use TAP::Base (); -use POSIX qw(strftime); - -use vars qw($VERSION @ISA); - -my $MAX_ERRORS = 5; -my %VALIDATION_FOR; - -BEGIN { - @ISA = qw(TAP::Base); - - %VALIDATION_FOR = ( - directives => sub { shift; shift }, - verbosity => sub { shift; shift }, - normalize => sub { shift; shift }, - timer => sub { shift; shift }, - failures => sub { shift; shift }, - comments => sub { shift; shift }, - errors => sub { shift; shift }, - color => sub { shift; shift }, - jobs => sub { shift; shift }, - show_count => sub { shift; shift }, - stdout => sub { - my ( $self, $ref ) = @_; - $self->_croak("option 'stdout' needs a filehandle") - unless ( ref $ref || '' ) eq 'GLOB' - or eval { $ref->can('print') }; - return $ref; - }, - ); - - my @getter_setters = qw( - _longest - _printed_summary_header - _colorizer - ); - - __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR ); -} - -=head1 NAME - -TAP::Formatter::Console - Harness output delegate for default console output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This provides console orientated output formatting for TAP::Harness. - -=head1 SYNOPSIS - - use TAP::Formatter::Console; - my $harness = TAP::Formatter::Console->new( \%args ); - -=cut - -sub _initialize { - my ( $self, $arg_for ) = @_; - $arg_for ||= {}; - - $self->SUPER::_initialize($arg_for); - my %arg_for = %$arg_for; # force a shallow copy - - $self->verbosity(0); - - for my $name ( keys %VALIDATION_FOR ) { - my $property = delete $arg_for{$name}; - if ( defined $property ) { - my $validate = $VALIDATION_FOR{$name}; - $self->$name( $self->$validate($property) ); - } - } - - if ( my @props = keys %arg_for ) { - $self->_croak( - "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); - } - - $self->stdout( \*STDOUT ) unless $self->stdout; - - if ( $self->color ) { - require TAP::Formatter::Color; - $self->_colorizer( TAP::Formatter::Color->new ); - } - - return $self; -} - -sub verbose { shift->verbosity >= 1 } -sub quiet { shift->verbosity <= -1 } -sub really_quiet { shift->verbosity <= -2 } -sub silent { shift->verbosity <= -3 } - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my %args = ( - verbose => 1, - ) - my $harness = TAP::Formatter::Console->new( \%args ); - -The constructor returns a new C<TAP::Formatter::Console> object. If -a L<TAP::Harness> is created with no C<formatter> a -C<TAP::Formatter::Console> is automatically created. If any of the -following options were given to TAP::Harness->new they well be passed to -this constructor which accepts an optional hashref whose allowed keys are: - -=over 4 - -=item * C<verbosity> - -Set the verbosity level. - -=item * C<verbose> - -Printing individual test results to STDOUT. - -=item * C<timer> - -Append run time for each test to output. Uses L<Time::HiRes> if available. - -=item * C<failures> - -Show test failures (this is a no-op if C<verbose> is selected). - -=item * C<comments> - -Show test comments (this is a no-op if C<verbose> is selected). - -=item * C<quiet> - -Suppressing some test output (mostly failures while tests are running). - -=item * C<really_quiet> - -Suppressing everything but the tests summary. - -=item * C<silent> - -Suppressing all output. - -=item * C<errors> - -If parse errors are found in the TAP output, a note of this will be made -in the summary report. To see all of the parse errors, set this argument to -true: - - errors => 1 - -=item * C<directives> - -If set to a true value, only test results with directives will be displayed. -This overrides other settings such as C<verbose>, C<failures>, or C<comments>. - -=item * C<stdout> - -A filehandle for catching standard output. - -=item * C<color> - -If defined specifies whether color output is desired. If C<color> is not -defined it will default to color output if color support is available on -the current platform and output is not being redirected. - -=item * C<jobs> - -The number of concurrent jobs this formatter will handle. - -=item * C<show_count> - -Boolean value. If false, disables the C<X/Y> test count which shows up while -tests are running. - -=back - -Any keys for which the value is C<undef> will be ignored. - -=cut - -# new supplied by TAP::Base - -=head3 C<prepare> - -Called by Test::Harness before any test output is generated. - -This is an advisory and may not be called in the case where tests are -being supplied to Test::Harness by an iterator. - -=cut - -sub prepare { - my ( $self, @tests ) = @_; - - my $longest = 0; - - foreach my $test (@tests) { - $longest = length $test if length $test > $longest; - } - - $self->_longest($longest); -} - -sub _format_now { strftime "[%H:%M:%S]", localtime } - -sub _format_name { - my ( $self, $test ) = @_; - my $name = $test; - my $periods = '.' x ( $self->_longest + 2 - length $test ); - $periods = " $periods "; - - if ( $self->timer ) { - my $stamp = $self->_format_now(); - return "$stamp $name$periods"; - } - else { - return "$name$periods"; - } - -} - -=head3 C<open_test> - -Called to create a new test session. A test session looks like this: - - my $session = $formatter->open_test( $test, $parser ); - while ( defined( my $result = $parser->next ) ) { - $session->result($result); - exit 1 if $result->is_bailout; - } - $session->close_test; - -=cut - -sub open_test { - die "Unimplemented."; -} - -sub _output_success { - my ( $self, $msg ) = @_; - $self->_output($msg); -} - -=head3 C<summary> - - $harness->summary( $aggregate ); - -C<summary> prints the summary report after all tests are run. The argument is -an aggregate. - -=cut - -sub summary { - my ( $self, $aggregate ) = @_; - - return if $self->silent; - - my @t = $aggregate->descriptions; - my $tests = \@t; - - my $runtime = $aggregate->elapsed_timestr; - - my $total = $aggregate->total; - my $passed = $aggregate->passed; - - if ( $self->timer ) { - $self->_output( $self->_format_now(), "\n" ); - } - - # TODO: Check this condition still works when all subtests pass but - # the exit status is nonzero - - if ( $aggregate->all_passed ) { - $self->_output_success("All tests successful.\n"); - } - - # ~TODO option where $aggregate->skipped generates reports - if ( $total != $passed or $aggregate->has_problems ) { - $self->_output("\nTest Summary Report"); - $self->_output("\n-------------------\n"); - foreach my $test (@$tests) { - $self->_printed_summary_header(0); - my ($parser) = $aggregate->parsers($test); - $self->_output_summary_failure( - 'failed', - [ ' Failed test: ', ' Failed tests: ' ], - $test, $parser - ); - $self->_output_summary_failure( - 'todo_passed', - " TODO passed: ", $test, $parser - ); - - # ~TODO this cannot be the default - #$self->_output_summary_failure( 'skipped', " Tests skipped: " ); - - if ( my $exit = $parser->exit ) { - $self->_summary_test_header( $test, $parser ); - $self->_failure_output(" Non-zero exit status: $exit\n"); - } - elsif ( my $wait = $parser->wait ) { - $self->_summary_test_header( $test, $parser ); - $self->_failure_output(" Non-zero wait status: $wait\n"); - } - - if ( my @errors = $parser->parse_errors ) { - my $explain; - if ( @errors > $MAX_ERRORS && !$self->errors ) { - $explain - = "Displayed the first $MAX_ERRORS of " - . scalar(@errors) - . " TAP syntax errors.\n" - . "Re-run prove with the -p option to see them all.\n"; - splice @errors, $MAX_ERRORS; - } - $self->_summary_test_header( $test, $parser ); - $self->_failure_output( - sprintf " Parse errors: %s\n", - shift @errors - ); - foreach my $error (@errors) { - my $spaces = ' ' x 16; - $self->_failure_output("$spaces$error\n"); - } - $self->_failure_output($explain) if $explain; - } - } - } - my $files = @$tests; - $self->_output("Files=$files, Tests=$total, $runtime\n"); - my $status = $aggregate->get_status; - $self->_output("Result: $status\n"); -} - -sub _output_summary_failure { - my ( $self, $method, $name, $test, $parser ) = @_; - - # ugly hack. Must rethink this :( - my $output = $method eq 'failed' ? '_failure_output' : '_output'; - - if ( my @r = $parser->$method() ) { - $self->_summary_test_header( $test, $parser ); - my ( $singular, $plural ) - = 'ARRAY' eq ref $name ? @$name : ( $name, $name ); - $self->$output( @r == 1 ? $singular : $plural ); - my @results = $self->_balanced_range( 40, @r ); - $self->$output( sprintf "%s\n" => shift @results ); - my $spaces = ' ' x 16; - while (@results) { - $self->$output( sprintf "$spaces%s\n" => shift @results ); - } - } -} - -sub _summary_test_header { - my ( $self, $test, $parser ) = @_; - return if $self->_printed_summary_header; - my $spaces = ' ' x ( $self->_longest - length $test ); - $spaces = ' ' unless $spaces; - my $output = $self->_get_output_method($parser); - $self->$output( - sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n", - $parser->wait, $parser->tests_run, scalar $parser->failed - ); - $self->_printed_summary_header(1); -} - -sub _output { - my $self = shift; - - print { $self->stdout } @_; -} - -sub _failure_output { - my $self = shift; - - $self->_output(@_); -} - -sub _balanced_range { - my ( $self, $limit, @range ) = @_; - @range = $self->_range(@range); - my $line = ""; - my @lines; - my $curr = 0; - while (@range) { - if ( $curr < $limit ) { - my $range = ( shift @range ) . ", "; - $line .= $range; - $curr += length $range; - } - elsif (@range) { - $line =~ s/, $//; - push @lines => $line; - $line = ''; - $curr = 0; - } - } - if ($line) { - $line =~ s/, $//; - push @lines => $line; - } - return @lines; -} - -sub _range { - my ( $self, @numbers ) = @_; - - # shouldn't be needed, but subclasses might call this - @numbers = sort { $a <=> $b } @numbers; - my ( $min, @range ); - - foreach my $i ( 0 .. $#numbers ) { - my $num = $numbers[$i]; - my $next = $numbers[ $i + 1 ]; - if ( defined $next && $next == $num + 1 ) { - if ( !defined $min ) { - $min = $num; - } - } - elsif ( defined $min ) { - push @range => "$min-$num"; - undef $min; - } - else { - push @range => $num; - } - } - return @range; -} - -sub _get_output_method { - my ( $self, $parser ) = @_; - return $parser->has_problems ? '_failure_output' : '_output'; -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Color.pm b/ext/Test-Harness/lib/TAP/Formatter/Color.pm deleted file mode 100644 index 349d3b84bf..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/Color.pm +++ /dev/null @@ -1,148 +0,0 @@ -package TAP::Formatter::Color; - -use strict; -use vars qw($VERSION @ISA); - -use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); - -@ISA = qw(TAP::Object); - -my $NO_COLOR; - -BEGIN { - $NO_COLOR = 0; - - if (IS_WIN32) { - eval 'use Win32::Console'; - if ($@) { - $NO_COLOR = $@; - } - else { - my $console = Win32::Console->new( STD_OUTPUT_HANDLE() ); - - # eval here because we might not know about these variables - my $fg = eval '$FG_LIGHTGRAY'; - my $bg = eval '$BG_BLACK'; - - *set_color = sub { - my ( $self, $output, $color ) = @_; - - my $var; - if ( $color eq 'reset' ) { - $fg = eval '$FG_LIGHTGRAY'; - $bg = eval '$BG_BLACK'; - } - elsif ( $color =~ /^on_(.+)$/ ) { - $bg = eval '$BG_' . uc($1); - } - else { - $fg = eval '$FG_' . uc($color); - } - - # In case of colors that aren't defined - $self->set_color('reset') - unless defined $bg && defined $fg; - - $console->Attr( $bg | $fg ); - }; - } - } - else { - eval 'use Term::ANSIColor'; - if ($@) { - $NO_COLOR = $@; - } - else { - *set_color = sub { - my ( $self, $output, $color ) = @_; - $output->( color($color) ); - }; - } - } - - if ($NO_COLOR) { - *set_color = sub { }; - } -} - -=head1 NAME - -TAP::Formatter::Color - Run Perl test scripts with color - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -Note that this harness is I<experimental>. You may not like the colors I've -chosen and I haven't yet provided an easy way to override them. - -This test harness is the same as L<TAP::Harness>, but test results are output -in color. Passing tests are printed in green. Failing tests are in red. -Skipped tests are blue on a white background and TODO tests are printed in -white. - -If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running -under Windows) tests will be run without color. - -=head1 SYNOPSIS - - use TAP::Formatter::Color; - my $harness = TAP::Formatter::Color->new( \%args ); - $harness->runtests(@tests); - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -The constructor returns a new C<TAP::Formatter::Color> object. If -L<Term::ANSIColor> is not installed, returns undef. - -=cut - -# new() implementation supplied by TAP::Object - -sub _initialize { - my $self = shift; - - if ($NO_COLOR) { - - # shorten that message a bit - ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s; - warn "Note: Cannot run tests in color: $error\n"; - return; # abort object construction - } - - return $self; -} - -############################################################################## - -=head3 C<can_color> - - Test::Formatter::Color->can_color() - -Returns a boolean indicating whether or not this module can actually -generate colored output. This will be false if it could not load the -modules needed for the current platform. - -=cut - -sub can_color { - return !$NO_COLOR; -} - -=head3 C<set_color> - -Set the output color. - -=cut - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console.pm b/ext/Test-Harness/lib/TAP/Formatter/Console.pm deleted file mode 100644 index aeca2f2b0d..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/Console.pm +++ /dev/null @@ -1,91 +0,0 @@ -package TAP::Formatter::Console; - -use strict; -use TAP::Formatter::Base (); -use POSIX qw(strftime); - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Base); - -=head1 NAME - -TAP::Formatter::Console - Harness output delegate for default console output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This provides console orientated output formatting for TAP::Harness. - -=head1 SYNOPSIS - - use TAP::Formatter::Console; - my $harness = TAP::Formatter::Console->new( \%args ); - -=head2 C<< open_test >> - -See L<TAP::Formatter::base> - -=cut - -sub open_test { - my ( $self, $test, $parser ) = @_; - - my $class - = $self->jobs > 1 - ? 'TAP::Formatter::Console::ParallelSession' - : 'TAP::Formatter::Console::Session'; - - eval "require $class"; - $self->_croak($@) if $@; - - my $session = $class->new( - { name => $test, - formatter => $self, - parser => $parser, - show_count => $self->show_count, - } - ); - - $session->header; - - return $session; -} - -# Use _colorizer delegate to set output color. NOP if we have no delegate -sub _set_colors { - my ( $self, @colors ) = @_; - if ( my $colorizer = $self->_colorizer ) { - my $output_func = $self->{_output_func} ||= sub { - $self->_output(@_); - }; - $colorizer->set_color( $output_func, $_ ) for @colors; - } -} - -sub _output_success { - my ( $self, $msg ) = @_; - $self->_set_colors('green'); - $self->_output($msg); - $self->_set_colors('reset'); -} - -sub _failure_output { - my $self = shift; - $self->_set_colors('red'); - my $out = join '', @_; - my $has_newline = chomp $out; - $self->_output($out); - $self->_set_colors('reset'); - $self->_output($/) - if $has_newline; -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm b/ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm deleted file mode 100644 index b6b5134cda..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm +++ /dev/null @@ -1,202 +0,0 @@ -package TAP::Formatter::Console::ParallelSession; - -use strict; -use File::Spec; -use File::Path; -use TAP::Formatter::Console::Session; -use Carp; - -use constant WIDTH => 72; # Because Eric says -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Console::Session); - -my %shared; - -sub _initialize { - my ( $self, $arg_for ) = @_; - - $self->SUPER::_initialize($arg_for); - my $formatter = $self->formatter; - - # Horrid bodge. This creates our shared context per harness. Maybe - # TAP::Harness should give us this? - my $context = $shared{$formatter} ||= $self->_create_shared_context; - push @{ $context->{active} }, $self; - - return $self; -} - -sub _create_shared_context { - my $self = shift; - return { - active => [], - tests => 0, - fails => 0, - }; -} - -=head1 NAME - -TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This provides console orientated output formatting for L<TAP::Harness> -when run with multiple L<TAP::Harness/jobs>. - -=head1 SYNOPSIS - -=cut - -=head1 METHODS - -=head2 Class Methods - -=head3 C<header> - -Output test preamble - -=cut - -sub header { -} - -sub _clear_ruler { - my $self = shift; - $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" ); -} - -my $now = 0; -my $start; - -my $trailer = '... )==='; -my $chop_length = WIDTH - length $trailer; - -sub _output_ruler { - my ( $self, $refresh ) = @_; - my $new_now = time; - return if $new_now == $now and !$refresh; - $now = $new_now; - $start ||= $now; - my $formatter = $self->formatter; - return if $formatter->really_quiet; - - my $context = $shared{$formatter}; - - my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; - - foreach my $active ( @{ $context->{active} } ) { - my $parser = $active->parser; - my $tests = $parser->tests_run; - my $planned = $parser->tests_planned || '?'; - - $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests; - } - chop $ruler; # Remove a trailing space - $ruler .= ')==='; - - if ( length $ruler > WIDTH ) { - $ruler =~ s/(.{$chop_length}).*/$1$trailer/o; - } - else { - $ruler .= '=' x ( WIDTH - length($ruler) ); - } - $formatter->_output("\r$ruler"); -} - -=head3 C<result> - - Called by the harness for each line of TAP it receives . - -=cut - -sub result { - my ( $self, $result ) = @_; - my $formatter = $self->formatter; - - # my $really_quiet = $formatter->really_quiet; - # my $show_count = $self->_should_show_count; - - if ( $result->is_test ) { - my $context = $shared{$formatter}; - $context->{tests}++; - - my $active = $context->{active}; - if ( @$active == 1 ) { - - # There is only one test, so use the serial output format. - return $self->SUPER::result($result); - } - - $self->_output_ruler( $self->parser->tests_run == 1 ); - } - elsif ( $result->is_bailout ) { - $formatter->_failure_output( - "Bailout called. Further testing stopped: " - . $result->explanation - . "\n" ); - } -} - -=head3 C<clear_for_close> - -=cut - -sub clear_for_close { - my $self = shift; - my $formatter = $self->formatter; - return if $formatter->really_quiet; - my $context = $shared{$formatter}; - if ( @{ $context->{active} } == 1 ) { - $self->SUPER::clear_for_close; - } - else { - $self->_clear_ruler; - } -} - -=head3 C<close_test> - -=cut - -sub close_test { - my $self = shift; - my $name = $self->name; - my $parser = $self->parser; - my $formatter = $self->formatter; - my $context = $shared{$formatter}; - - $self->SUPER::close_test; - - my $active = $context->{active}; - - my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active; - - die "Can't find myself" unless @pos; - splice @$active, $pos[0], 1; - - if ( @$active > 1 ) { - $self->_output_ruler(1); - } - elsif ( @$active == 1 ) { - - # Print out "test/name.t ...." - $active->[0]->SUPER::header; - } - else { - - # $self->formatter->_output("\n"); - delete $shared{$formatter}; - } -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm b/ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm deleted file mode 100644 index 675512c71d..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm +++ /dev/null @@ -1,219 +0,0 @@ -package TAP::Formatter::Console::Session; - -use strict; -use TAP::Formatter::Session; - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Session); - -my @ACCESSOR; - -BEGIN { - my @CLOSURE_BINDING = qw( header result clear_for_close close_test ); - - for my $method (@CLOSURE_BINDING) { - no strict 'refs'; - *$method = sub { - my $self = shift; - return ( $self->{_closures} ||= $self->_closures )->{$method} - ->(@_); - }; - } -} - -=head1 NAME - -TAP::Formatter::Console::Session - Harness output delegate for default console output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This provides console orientated output formatting for TAP::Harness. - -=cut - -sub _get_output_result { - my $self = shift; - - my @color_map = ( - { test => sub { $_->is_test && !$_->is_ok }, - colors => ['red'], - }, - { test => sub { $_->is_test && $_->has_skip }, - colors => [ - 'white', - 'on_blue' - ], - }, - { test => sub { $_->is_test && $_->has_todo }, - colors => ['yellow'], - }, - ); - - my $formatter = $self->formatter; - my $parser = $self->parser; - - return $formatter->_colorizer - ? sub { - my $result = shift; - for my $col (@color_map) { - local $_ = $result; - if ( $col->{test}->() ) { - $formatter->_set_colors( @{ $col->{colors} } ); - last; - } - } - $formatter->_output( $self->_format_for_output($result) ); - $formatter->_set_colors('reset'); - } - : sub { - $formatter->_output( $self->_format_for_output(shift) ); - }; -} - -sub _closures { - my $self = shift; - - my $parser = $self->parser; - my $formatter = $self->formatter; - my $pretty = $formatter->_format_name( $self->name ); - my $show_count = $self->show_count; - - my $really_quiet = $formatter->really_quiet; - my $quiet = $formatter->quiet; - my $verbose = $formatter->verbose; - my $directives = $formatter->directives; - my $failures = $formatter->failures; - my $comments = $formatter->comments; - - my $output_result = $self->_get_output_result; - - my $output = '_output'; - my $plan = ''; - my $newline_printed = 0; - - my $last_status_printed = 0; - - return { - header => sub { - $formatter->_output($pretty) - unless $really_quiet; - }, - - result => sub { - my $result = shift; - - if ( $result->is_bailout ) { - $formatter->_failure_output( - "Bailout called. Further testing stopped: " - . $result->explanation - . "\n" ); - } - - return if $really_quiet; - - my $is_test = $result->is_test; - - # These are used in close_test - but only if $really_quiet - # is false - so it's safe to only set them here unless that - # relationship changes. - - if ( !$plan ) { - my $planned = $parser->tests_planned || '?'; - $plan = "/$planned "; - } - $output = $formatter->_get_output_method($parser); - - if ( $show_count and $is_test ) { - my $number = $result->number; - my $now = CORE::time; - - # Print status roughly once per second. - # We will always get the first number as a side effect of - # $last_status_printed starting with the value 0, which $now - # will never be. (Unless someone sets their clock to 1970) - if ( $last_status_printed != $now ) { - $formatter->$output("\r$pretty$number$plan"); - $last_status_printed = $now; - } - } - - if (!$quiet - && ( $verbose - || ( $is_test && $failures && !$result->is_ok ) - || ( $comments && $result->is_comment ) - || ( $directives && $result->has_directive ) ) - ) - { - unless ($newline_printed) { - $formatter->_output("\n"); - $newline_printed = 1; - } - $output_result->($result); - $formatter->_output("\n"); - } - }, - - clear_for_close => sub { - my $spaces - = ' ' x length( '.' . $pretty . $plan . $parser->tests_run ); - $formatter->$output("\r$spaces"); - }, - - close_test => sub { - if ( $show_count && !$really_quiet ) { - $self->clear_for_close; - $formatter->$output("\r$pretty"); - } - - # Avoid circular references - $self->parser(undef); - $self->{_closures} = {}; - - return if $really_quiet; - - if ( my $skip_all = $parser->skip_all ) { - $formatter->_output("skipped: $skip_all\n"); - } - elsif ( $parser->has_problems ) { - $self->_output_test_failure($parser); - } - else { - my $time_report = ''; - if ( $formatter->timer ) { - my $start_time = $parser->start_time; - my $end_time = $parser->end_time; - if ( defined $start_time and defined $end_time ) { - my $elapsed = $end_time - $start_time; - $time_report - = $self->time_is_hires - ? sprintf( ' %8d ms', $elapsed * 1000 ) - : sprintf( ' %8s s', $elapsed || '<1' ); - } - } - - $formatter->_output("ok$time_report\n"); - } - }, - }; -} - -=head2 C<< clear_for_close >> - -=head2 C<< close_test >> - -=head2 C<< header >> - -=head2 C<< result >> - -=cut - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/File.pm b/ext/Test-Harness/lib/TAP/Formatter/File.pm deleted file mode 100644 index 8514bc068b..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/File.pm +++ /dev/null @@ -1,58 +0,0 @@ -package TAP::Formatter::File; - -use strict; -use TAP::Formatter::Base (); -use TAP::Formatter::File::Session; -use POSIX qw(strftime); - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Base); - -=head1 NAME - -TAP::Formatter::File - Harness output delegate for file output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This provides file orientated output formatting for TAP::Harness. - -=head1 SYNOPSIS - - use TAP::Formatter::File; - my $harness = TAP::Formatter::File->new( \%args ); - -=head2 C<< open_test >> - -See L<TAP::Formatter::base> - -=cut - -sub open_test { - my ( $self, $test, $parser ) = @_; - - my $session = TAP::Formatter::File::Session->new( - { name => $test, - formatter => $self, - parser => $parser, - } - ); - - $session->header; - - return $session; -} - -sub _should_show_count { - return 0; -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/File/Session.pm b/ext/Test-Harness/lib/TAP/Formatter/File/Session.pm deleted file mode 100644 index c6abfd63bc..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/File/Session.pm +++ /dev/null @@ -1,110 +0,0 @@ -package TAP::Formatter::File::Session; - -use strict; -use TAP::Formatter::Session; - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Session); - -=head1 NAME - -TAP::Formatter::File::Session - Harness output delegate for file output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This provides file orientated output formatting for L<TAP::Harness>. -It is particularly important when running with parallel tests, as it -ensures that test results are not interleaved, even when run -verbosely. - -=cut - -=head1 METHODS - -=head2 result - -Stores results for later output, all together. - -=cut - -sub result { - my $self = shift; - my $result = shift; - - my $parser = $self->parser; - my $formatter = $self->formatter; - - if ( $result->is_bailout ) { - $formatter->_failure_output( - "Bailout called. Further testing stopped: " - . $result->explanation - . "\n" ); - return; - } - - if (!$formatter->quiet - && ( $formatter->verbose - || ( $result->is_test && $formatter->failures && !$result->is_ok ) - || ( $formatter->comments && $result->is_comment ) - || ( $result->has_directive && $formatter->directives ) ) - ) - { - $self->{results} .= $self->_format_for_output($result) . "\n"; - } -} - -=head2 close_test - -When the test file finishes, outputs the summary, together. - -=cut - -sub close_test { - my $self = shift; - - # Avoid circular references - $self->parser(undef); - - my $parser = $self->parser; - my $formatter = $self->formatter; - my $pretty = $formatter->_format_name( $self->name ); - - return if $formatter->really_quiet; - if ( my $skip_all = $parser->skip_all ) { - $formatter->_output( $pretty . "skipped: $skip_all\n" ); - } - elsif ( $parser->has_problems ) { - $formatter->_output( - $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) ); - $self->_output_test_failure($parser); - } - else { - my $time_report = ''; - if ( $formatter->timer ) { - my $start_time = $parser->start_time; - my $end_time = $parser->end_time; - if ( defined $start_time and defined $end_time ) { - my $elapsed = $end_time - $start_time; - $time_report - = $self->time_is_hires - ? sprintf( ' %8d ms', $elapsed * 1000 ) - : sprintf( ' %8s s', $elapsed || '<1' ); - } - } - - $formatter->_output( $pretty - . ( $self->{results} ? "\n" . $self->{results} : "" ) - . "ok$time_report\n" ); - } -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Session.pm b/ext/Test-Harness/lib/TAP/Formatter/Session.pm deleted file mode 100644 index 21767e5eba..0000000000 --- a/ext/Test-Harness/lib/TAP/Formatter/Session.pm +++ /dev/null @@ -1,183 +0,0 @@ -package TAP::Formatter::Session; - -use strict; -use TAP::Base; - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Base); - -my @ACCESSOR; - -BEGIN { - - @ACCESSOR = qw( name formatter parser show_count ); - - for my $method (@ACCESSOR) { - no strict 'refs'; - *$method = sub { shift->{$method} }; - } -} - -=head1 NAME - -TAP::Formatter::Session - Abstract base class for harness output delegate - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my %args = ( - formatter => $self, - ) - my $harness = TAP::Formatter::Console::Session->new( \%args ); - -The constructor returns a new C<TAP::Formatter::Console::Session> object. - -=over 4 - -=item * C<formatter> - -=item * C<parser> - -=item * C<name> - -=item * C<show_count> - -=back - -=cut - -sub _initialize { - my ( $self, $arg_for ) = @_; - $arg_for ||= {}; - - $self->SUPER::_initialize($arg_for); - my %arg_for = %$arg_for; # force a shallow copy - - for my $name (@ACCESSOR) { - $self->{$name} = delete $arg_for{$name}; - } - - if ( !defined $self->show_count ) { - $self->{show_count} = 1; # defaults to true - } - if ( $self->show_count ) { # but may be a damned lie! - $self->{show_count} = $self->_should_show_count; - } - - if ( my @props = sort keys %arg_for ) { - $self->_croak( - "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); - } - - return $self; -} - -=head3 C<header> - -Output test preamble - -=head3 C<result> - -Called by the harness for each line of TAP it receives. - -=head3 C<close_test> - -Called to close a test session. - -=head3 C<clear_for_close> - -Called by C<close_test> to clear the line showing test progress, or the parallel -test ruler, prior to printing the final test result. - -=cut - -sub header { } - -sub result { } - -sub close_test { } - -sub clear_for_close { } - -sub _should_show_count { - my $self = shift; - return - !$self->formatter->verbose - && -t $self->formatter->stdout - && !$ENV{HARNESS_NOTTY}; -} - -sub _format_for_output { - my ( $self, $result ) = @_; - return $self->formatter->normalize ? $result->as_string : $result->raw; -} - -sub _output_test_failure { - my ( $self, $parser ) = @_; - my $formatter = $self->formatter; - return if $formatter->really_quiet; - - my $tests_run = $parser->tests_run; - my $tests_planned = $parser->tests_planned; - - my $total - = defined $tests_planned - ? $tests_planned - : $tests_run; - - my $passed = $parser->passed; - - # The total number of fails includes any tests that were planned but - # didn't run - my $failed = $parser->failed + $total - $tests_run; - my $exit = $parser->exit; - - if ( my $exit = $parser->exit ) { - my $wstat = $parser->wait; - my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat ); - $formatter->_failure_output("Dubious, test returned $status\n"); - } - - if ( $failed == 0 ) { - $formatter->_failure_output( - $total - ? "All $total subtests passed " - : 'No subtests run ' - ); - } - else { - $formatter->_failure_output("Failed $failed/$total subtests "); - if ( !$total ) { - $formatter->_failure_output("\nNo tests run!"); - } - } - - if ( my $skipped = $parser->skipped ) { - $passed -= $skipped; - my $test = 'subtest' . ( $skipped != 1 ? 's' : '' ); - $formatter->_output( - "\n\t(less $skipped skipped $test: $passed okay)"); - } - - if ( my $failed = $parser->todo_passed ) { - my $test = $failed > 1 ? 'tests' : 'test'; - $formatter->_output( - "\n\t($failed TODO $test unexpectedly succeeded)"); - } - - $formatter->_output("\n"); -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Harness.pm b/ext/Test-Harness/lib/TAP/Harness.pm deleted file mode 100644 index 749e7af416..0000000000 --- a/ext/Test-Harness/lib/TAP/Harness.pm +++ /dev/null @@ -1,830 +0,0 @@ -package TAP::Harness; - -use strict; -use Carp; - -use File::Spec; -use File::Path; -use IO::Handle; - -use TAP::Base; - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Base); - -=head1 NAME - -TAP::Harness - Run test scripts with statistics - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -$ENV{HARNESS_ACTIVE} = 1; -$ENV{HARNESS_VERSION} = $VERSION; - -END { - - # For VMS. - delete $ENV{HARNESS_ACTIVE}; - delete $ENV{HARNESS_VERSION}; -} - -=head1 DESCRIPTION - -This is a simple test harness which allows tests to be run and results -automatically aggregated and output to STDOUT. - -=head1 SYNOPSIS - - use TAP::Harness; - my $harness = TAP::Harness->new( \%args ); - $harness->runtests(@tests); - -=cut - -my %VALIDATION_FOR; -my @FORMATTER_ARGS; - -sub _error { - my $self = shift; - return $self->{error} unless @_; - $self->{error} = shift; -} - -BEGIN { - - @FORMATTER_ARGS = qw( - directives verbosity timer failures comments errors stdout color - show_count normalize - ); - - %VALIDATION_FOR = ( - lib => sub { - my ( $self, $libs ) = @_; - $libs = [$libs] unless 'ARRAY' eq ref $libs; - - return [ map {"-I$_"} @$libs ]; - }, - switches => sub { shift; shift }, - exec => sub { shift; shift }, - merge => sub { shift; shift }, - aggregator_class => sub { shift; shift }, - formatter_class => sub { shift; shift }, - multiplexer_class => sub { shift; shift }, - parser_class => sub { shift; shift }, - scheduler_class => sub { shift; shift }, - formatter => sub { shift; shift }, - jobs => sub { shift; shift }, - test_args => sub { shift; shift }, - ignore_exit => sub { shift; shift }, - rules => sub { shift; shift }, - ); - - for my $method ( sort keys %VALIDATION_FOR ) { - no strict 'refs'; - if ( $method eq 'lib' || $method eq 'switches' ) { - *{$method} = sub { - my $self = shift; - unless (@_) { - $self->{$method} ||= []; - return wantarray - ? @{ $self->{$method} } - : $self->{$method}; - } - $self->_croak("Too many arguments to method '$method'") - if @_ > 1; - my $args = shift; - $args = [$args] unless ref $args; - $self->{$method} = $args; - return $self; - }; - } - else { - *{$method} = sub { - my $self = shift; - return $self->{$method} unless @_; - $self->{$method} = shift; - }; - } - } - - for my $method (@FORMATTER_ARGS) { - no strict 'refs'; - *{$method} = sub { - my $self = shift; - return $self->formatter->$method(@_); - }; - } -} - -############################################################################## - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my %args = ( - verbosity => 1, - lib => [ 'lib', 'blib/lib', 'blib/arch' ], - ) - my $harness = TAP::Harness->new( \%args ); - -The constructor returns a new C<TAP::Harness> object. It accepts an -optional hashref whose allowed keys are: - -=over 4 - -=item * C<verbosity> - -Set the verbosity level: - - 1 verbose Print individual test results to STDOUT. - 0 normal - -1 quiet Suppress some test output (mostly failures - while tests are running). - -2 really quiet Suppress everything but the tests summary. - -3 silent Suppress everything. - -=item * C<timer> - -Append run time for each test to output. Uses L<Time::HiRes> if -available. - -=item * C<failures> - -Show test failures (this is a no-op if C<verbose> is selected). - -=item * C<comments> - -Show test comments (this is a no-op if C<verbose> is selected). - -=item * C<show_count> - -Update the running test count during testing. - -=item * C<normalize> - -Set to a true value to normalize the TAP that is emitted in verbose modes. - -=item * C<lib> - -Accepts a scalar value or array ref of scalar values indicating which -paths to allowed libraries should be included if Perl tests are -executed. Naturally, this only makes sense in the context of tests -written in Perl. - -=item * C<switches> - -Accepts a scalar value or array ref of scalar values indicating which -switches should be included if Perl tests are executed. Naturally, this -only makes sense in the context of tests written in Perl. - -=item * C<test_args> - -A reference to an C<@INC> style array of arguments to be passed to each -test program. - -=item * C<color> - -Attempt to produce color output. - -=item * C<exec> - -Typically, Perl tests are run through this. However, anything which -spits out TAP is fine. You can use this argument to specify the name of -the program (and optional switches) to run your tests with: - - exec => ['/usr/bin/ruby', '-w'] - -You can also pass a subroutine reference in order to determine and -return the proper program to run based on a given test script. The -subroutine reference should expect the TAP::Harness object itself as the -first argument, and the file name as the second argument. It should -return an array reference containing the command to be run and including -the test file name. It can also simply return C<undef>, in which case -TAP::Harness will fall back on executing the test script in Perl: - - exec => sub { - my ( $harness, $test_file ) = @_; - - # Let Perl tests run. - return undef if $test_file =~ /[.]t$/; - return [ qw( /usr/bin/ruby -w ), $test_file ] - if $test_file =~ /[.]rb$/; - } - -If the subroutine returns a scalar with a newline or a filehandle, it -will be interpreted as raw TAP or as a TAP stream, respectively. - -=item * C<merge> - -If C<merge> is true the harness will create parsers that merge STDOUT -and STDERR together for any processes they start. - -=item * C<aggregator_class> - -The name of the class to use to aggregate test results. The default is -L<TAP::Parser::Aggregator>. - -=item * C<formatter_class> - -The name of the class to use to format output. The default is -L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output -isn't a TTY. - -=item * C<multiplexer_class> - -The name of the class to use to multiplex tests during parallel testing. -The default is L<TAP::Parser::Multiplexer>. - -=item * C<parser_class> - -The name of the class to use to parse TAP. The default is -L<TAP::Parser>. - -=item * C<scheduler_class> - -The name of the class to use to schedule test execution. The default is -L<TAP::Parser::Scheduler>. - -=item * C<formatter> - -If set C<formatter> must be an object that is capable of formatting the -TAP output. See L<TAP::Formatter::Console> for an example. - -=item * C<errors> - -If parse errors are found in the TAP output, a note of this will be -made in the summary report. To see all of the parse errors, set this -argument to true: - - errors => 1 - -=item * C<directives> - -If set to a true value, only test results with directives will be -displayed. This overrides other settings such as C<verbose> or -C<failures>. - -=item * C<ignore_exit> - -If set to a true value instruct C<TAP::Parser> to ignore exit and wait -status from test scripts. - -=item * C<jobs> - -The maximum number of parallel tests to run at any time. Which tests -can be run in parallel is controlled by C<rules>. The default is to -run only one test at a time. - -=item * C<rules> - -A reference to a hash of rules that control which tests may be -executed in parallel. This is an experimental feature and the -interface may change. - - $harness->rules( - { par => [ - { seq => '../ext/DB_File/t/*' }, - { seq => '../ext/IO_Compress_Zlib/t/*' }, - { seq => '../lib/CPANPLUS/*' }, - { seq => '../lib/ExtUtils/t/*' }, - '*' - ] - } - ); - -=item * C<stdout> - -A filehandle for catching standard output. - -=back - -Any keys for which the value is C<undef> will be ignored. - -=cut - -# new supplied by TAP::Base - -{ - my @legal_callback = qw( - parser_args - made_parser - before_runtests - after_runtests - after_test - ); - - my %default_class = ( - aggregator_class => 'TAP::Parser::Aggregator', - formatter_class => 'TAP::Formatter::Console', - multiplexer_class => 'TAP::Parser::Multiplexer', - parser_class => 'TAP::Parser', - scheduler_class => 'TAP::Parser::Scheduler', - ); - - sub _initialize { - my ( $self, $arg_for ) = @_; - $arg_for ||= {}; - - $self->SUPER::_initialize( $arg_for, \@legal_callback ); - my %arg_for = %$arg_for; # force a shallow copy - - for my $name ( sort keys %VALIDATION_FOR ) { - my $property = delete $arg_for{$name}; - if ( defined $property ) { - my $validate = $VALIDATION_FOR{$name}; - - my $value = $self->$validate($property); - if ( $self->_error ) { - $self->_croak; - } - $self->$name($value); - } - } - - $self->jobs(1) unless defined $self->jobs; - - local $default_class{formatter_class} = 'TAP::Formatter::File' - unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY}; - - while ( my ( $attr, $class ) = each %default_class ) { - $self->$attr( $self->$attr() || $class ); - } - - unless ( $self->formatter ) { - - # This is a little bodge to preserve legacy behaviour. It's - # pretty horrible that we know which args are destined for - # the formatter. - my %formatter_args = ( jobs => $self->jobs ); - for my $name (@FORMATTER_ARGS) { - if ( defined( my $property = delete $arg_for{$name} ) ) { - $formatter_args{$name} = $property; - } - } - - $self->formatter( - $self->_construct( $self->formatter_class, \%formatter_args ) - ); - } - - if ( my @props = sort keys %arg_for ) { - $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); - } - - return $self; - } -} - -############################################################################## - -=head2 Instance Methods - -=head3 C<runtests> - - $harness->runtests(@tests); - -Accepts and array of C<@tests> to be run. This should generally be the -names of test files, but this is not required. Each element in C<@tests> -will be passed to C<TAP::Parser::new()> as a C<source>. See -L<TAP::Parser> for more information. - -It is possible to provide aliases that will be displayed in place of the -test name by supplying the test as a reference to an array containing -C<< [ $test, $alias ] >>: - - $harness->runtests( [ 't/foo.t', 'Foo Once' ], - [ 't/foo.t', 'Foo Twice' ] ); - -Normally it is an error to attempt to run the same test twice. Aliases -allow you to overcome this limitation by giving each run of the test a -unique name. - -Tests will be run in the order found. - -If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it -should name a directory into which a copy of the raw TAP for each test -will be written. TAP is written to files named for each test. -Subdirectories will be created as needed. - -Returns a L<TAP::Parser::Aggregator> containing the test results. - -=cut - -sub runtests { - my ( $self, @tests ) = @_; - - my $aggregate = $self->_construct( $self->aggregator_class ); - - $self->_make_callback( 'before_runtests', $aggregate ); - $aggregate->start; - $self->aggregate_tests( $aggregate, @tests ); - $aggregate->stop; - $self->summary($aggregate); - $self->_make_callback( 'after_runtests', $aggregate ); - - return $aggregate; -} - -=head3 C<summary> - -Output the summary for a TAP::Parser::Aggregator. - -=cut - -sub summary { - my ( $self, $aggregate ) = @_; - $self->formatter->summary($aggregate); -} - -sub _after_test { - my ( $self, $aggregate, $job, $parser ) = @_; - - $self->_make_callback( 'after_test', $job->as_array_ref, $parser ); - $aggregate->add( $job->description, $parser ); -} - -sub _bailout { - my ( $self, $result ) = @_; - my $explanation = $result->explanation; - die "FAILED--Further testing stopped" - . ( $explanation ? ": $explanation\n" : ".\n" ); -} - -sub _aggregate_parallel { - my ( $self, $aggregate, $scheduler ) = @_; - - my $jobs = $self->jobs; - my $mux = $self->_construct( $self->multiplexer_class ); - - RESULT: { - - # Keep multiplexer topped up - FILL: - while ( $mux->parsers < $jobs ) { - my $job = $scheduler->get_job; - - # If we hit a spinner stop filling and start running. - last FILL if !defined $job || $job->is_spinner; - - my ( $parser, $session ) = $self->make_parser($job); - $mux->add( $parser, [ $session, $job ] ); - } - - if ( my ( $parser, $stash, $result ) = $mux->next ) { - my ( $session, $job ) = @$stash; - if ( defined $result ) { - $session->result($result); - $self->_bailout($result) if $result->is_bailout; - } - else { - - # End of parser. Automatically removed from the mux. - $self->finish_parser( $parser, $session ); - $self->_after_test( $aggregate, $job, $parser ); - $job->finish; - } - redo RESULT; - } - } - - return; -} - -sub _aggregate_single { - my ( $self, $aggregate, $scheduler ) = @_; - - JOB: - while ( my $job = $scheduler->get_job ) { - next JOB if $job->is_spinner; - - my ( $parser, $session ) = $self->make_parser($job); - - while ( defined( my $result = $parser->next ) ) { - $session->result($result); - if ( $result->is_bailout ) { - - # Keep reading until input is exhausted in the hope - # of allowing any pending diagnostics to show up. - 1 while $parser->next; - $self->_bailout($result); - } - } - - $self->finish_parser( $parser, $session ); - $self->_after_test( $aggregate, $job, $parser ); - $job->finish; - } - - return; -} - -=head3 C<aggregate_tests> - - $harness->aggregate_tests( $aggregate, @tests ); - -Run the named tests and display a summary of result. Tests will be run -in the order found. - -Test results will be added to the supplied L<TAP::Parser::Aggregator>. -C<aggregate_tests> may be called multiple times to run several sets of -tests. Multiple C<Test::Harness> instances may be used to pass results -to a single aggregator so that different parts of a complex test suite -may be run using different C<TAP::Harness> settings. This is useful, for -example, in the case where some tests should run in parallel but others -are unsuitable for parallel execution. - - my $formatter = TAP::Formatter::Console->new; - my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); - my $par_harness = TAP::Harness->new( - { formatter => $formatter, - jobs => 9 - } - ); - my $aggregator = TAP::Parser::Aggregator->new; - - $aggregator->start(); - $ser_harness->aggregate_tests( $aggregator, @ser_tests ); - $par_harness->aggregate_tests( $aggregator, @par_tests ); - $aggregator->stop(); - $formatter->summary($aggregator); - -Note that for simpler testing requirements it will often be possible to -replace the above code with a single call to C<runtests>. - -Each elements of the @tests array is either - -=over - -=item * the file name of a test script to run - -=item * a reference to a [ file name, display name ] array - -=back - -When you supply a separate display name it becomes possible to run a -test more than once; the display name is effectively the alias by which -the test is known inside the harness. The harness doesn't care if it -runs the same script more than once when each invocation uses a -different name. - -=cut - -sub aggregate_tests { - my ( $self, $aggregate, @tests ) = @_; - - my $jobs = $self->jobs; - my $scheduler = $self->make_scheduler(@tests); - - # #12458 - local $ENV{HARNESS_IS_VERBOSE} = 1 - if $self->formatter->verbosity > 0; - - # Formatter gets only names. - $self->formatter->prepare( map { $_->description } $scheduler->get_all ); - - if ( $self->jobs > 1 ) { - $self->_aggregate_parallel( $aggregate, $scheduler ); - } - else { - $self->_aggregate_single( $aggregate, $scheduler ); - } - - return; -} - -sub _add_descriptions { - my $self = shift; - - # Turn unwrapped scalars into anonymous arrays and copy the name as - # the description for tests that have only a name. - return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ } - map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_; -} - -=head3 C<make_scheduler> - -Called by the harness when it needs to create a -L<TAP::Parser::Scheduler>. Override in a subclass to provide an -alternative scheduler. C<make_scheduler> is passed the list of tests -that was passed to C<aggregate_tests>. - -=cut - -sub make_scheduler { - my ( $self, @tests ) = @_; - return $self->_construct( - $self->scheduler_class, - tests => [ $self->_add_descriptions(@tests) ], - rules => $self->rules - ); -} - -=head3 C<jobs> - -Gets or sets the number of concurrent test runs the harness is -handling. By default, this value is 1 -- for parallel testing, this -should be set higher. - -=cut - -############################################################################## - -=head1 SUBCLASSING - -C<TAP::Harness> is designed to be (mostly) easy to subclass. If you -don't like how a particular feature functions, just override the -desired methods. - -=head2 Methods - -TODO: This is out of date - -The following methods are ones you may wish to override if you want to -subclass C<TAP::Harness>. - -=head3 C<summary> - - $harness->summary( \%args ); - -C<summary> prints the summary report after all tests are run. The -argument is a hashref with the following keys: - -=over 4 - -=item * C<start> - -This is created with C<< Benchmark->new >> and it the time the tests -started. You can print a useful summary time, if desired, with: - - $self->output( - timestr( timediff( Benchmark->new, $start_time ), 'nop' ) ); - -=item * C<tests> - -This is an array reference of all test names. To get the L<TAP::Parser> -object for individual tests: - - my $aggregate = $args->{aggregate}; - my $tests = $args->{tests}; - - for my $name ( @$tests ) { - my ($parser) = $aggregate->parsers($test); - ... do something with $parser - } - -This is a bit clunky and will be cleaned up in a later release. - -=back - -=cut - -sub _get_parser_args { - my ( $self, $job ) = @_; - my $test_prog = $job->filename; - my %args = (); - my @switches; - @switches = $self->lib if $self->lib; - push @switches => $self->switches if $self->switches; - $args{switches} = \@switches; - $args{spool} = $self->_open_spool($test_prog); - $args{merge} = $self->merge; - $args{ignore_exit} = $self->ignore_exit; - - if ( my $exec = $self->exec ) { - $args{exec} - = ref $exec eq 'CODE' - ? $exec->( $self, $test_prog ) - : [ @$exec, $test_prog ]; - if ( not defined $args{exec} ) { - $args{source} = $test_prog; - } - elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) { - $args{source} = delete $args{exec}; - } - } - else { - $args{source} = $test_prog; - } - - if ( defined( my $test_args = $self->test_args ) ) { - $args{test_args} = $test_args; - } - - return \%args; -} - -=head3 C<make_parser> - -Make a new parser and display formatter session. Typically used and/or -overridden in subclasses. - - my ( $parser, $session ) = $harness->make_parser; - -=cut - -sub make_parser { - my ( $self, $job ) = @_; - - my $args = $self->_get_parser_args($job); - $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); - my $parser = $self->_construct( $self->parser_class, $args ); - - $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); - my $session = $self->formatter->open_test( $job->description, $parser ); - - return ( $parser, $session ); -} - -=head3 C<finish_parser> - -Terminate use of a parser. Typically used and/or overridden in -subclasses. The parser isn't destroyed as a result of this. - -=cut - -sub finish_parser { - my ( $self, $parser, $session ) = @_; - - $session->close_test; - $self->_close_spool($parser); - - return $parser; -} - -sub _open_spool { - my $self = shift; - my $test = shift; - - if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { - - my $spool = File::Spec->catfile( $spool_dir, $test ); - - # Make the directory - my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); - my $path = File::Spec->catpath( $vol, $dir, '' ); - eval { mkpath($path) }; - $self->_croak($@) if $@; - - my $spool_handle = IO::Handle->new; - open( $spool_handle, ">$spool" ) - or $self->_croak(" Can't write $spool ( $! ) "); - - return $spool_handle; - } - - return; -} - -sub _close_spool { - my $self = shift; - my ($parser) = @_; - - if ( my $spool_handle = $parser->delete_spool ) { - close($spool_handle) - or $self->_croak(" Error closing TAP spool file( $! ) \n "); - } - - return; -} - -sub _croak { - my ( $self, $message ) = @_; - unless ($message) { - $message = $self->_error; - } - $self->SUPER::_croak($message); - - return; -} - -=head1 REPLACING - -If you like the C<prove> utility and L<TAP::Parser> but you want your -own harness, all you need to do is write one and provide C<new> and -C<runtests> methods. Then you can use the C<prove> utility like so: - - prove --harness My::Test::Harness - -Note that while C<prove> accepts a list of tests (or things to be -tested), C<new> 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<Test::Harness> - -=cut - -1; - -# vim:ts=4:sw=4:et:sta diff --git a/ext/Test-Harness/lib/TAP/Object.pm b/ext/Test-Harness/lib/TAP/Object.pm deleted file mode 100644 index 498bb805c9..0000000000 --- a/ext/Test-Harness/lib/TAP/Object.pm +++ /dev/null @@ -1,139 +0,0 @@ -package TAP::Object; - -use strict; -use vars qw($VERSION); - -=head1 NAME - -TAP::Object - Base class that provides common functionality to all C<TAP::*> modules - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - package TAP::Whatever; - - use strict; - use vars qw(@ISA); - - use TAP::Object; - - @ISA = qw(TAP::Object); - - # new() implementation by TAP::Object - sub _initialize { - my ( $self, @args) = @_; - # initialize your object - return $self; - } - - # ... later ... - my $obj = TAP::Whatever->new(@args); - -=head1 DESCRIPTION - -C<TAP::Object> provides a default constructor and exception model for all -C<TAP::*> classes. Exceptions are raised using L<Carp>. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -Create a new object. Any arguments passed to C<new> will be passed on to the -L</_initialize> method. Returns a new object. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - return $self->_initialize(@_); -} - -=head2 Instance Methods - -=head3 C<_initialize> - -Initializes a new object. This method is a stub by default, you should override -it as appropriate. - -I<Note:> L</new> expects you to return C<$self> or raise an exception. See -L</_croak>, and L<Carp>. - -=cut - -sub _initialize { - return $_[0]; -} - -=head3 C<_croak> - -Raise an exception using C<croak> from L<Carp>, eg: - - $self->_croak( 'why me?', 'aaarrgh!' ); - -May also be called as a I<class> method. - - $class->_croak( 'this works too' ); - -=cut - -sub _croak { - my $proto = shift; - require Carp; - Carp::croak(@_); - return; -} - -=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<mk_methods> - -Create simple getter/setters. - - __PACKAGE__->mk_methods(@method_names); - -=cut - -sub mk_methods { - my ( $class, @methods ) = @_; - foreach 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; - diff --git a/ext/Test-Harness/lib/TAP/Parser.pm b/ext/Test-Harness/lib/TAP/Parser.pm deleted file mode 100644 index ea3acd907f..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser.pm +++ /dev/null @@ -1,1873 +0,0 @@ -package TAP::Parser; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Base (); -use TAP::Parser::Grammar (); -use TAP::Parser::Result (); -use TAP::Parser::ResultFactory (); -use TAP::Parser::Source (); -use TAP::Parser::Source::Perl (); -use TAP::Parser::Iterator (); -use TAP::Parser::IteratorFactory (); - -use Carp qw( confess ); - -=head1 NAME - -TAP::Parser - Parse L<TAP|Test::Harness::TAP> output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -my $DEFAULT_TAP_VERSION = 12; -my $MAX_TAP_VERSION = 13; - -$ENV{TAP_VERSION} = $MAX_TAP_VERSION; - -END { - - # For VMS. - delete $ENV{TAP_VERSION}; -} - -BEGIN { # making accessors - @ISA = qw(TAP::Base); - - __PACKAGE__->mk_methods( - qw( - _stream - _spool - exec - exit - is_good_plan - plan - tests_planned - tests_run - wait - version - in_todo - start_time - end_time - skip_all - source_class - perl_source_class - grammar_class - iterator_factory_class - result_factory_class - ) - ); -} # 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<TAP::Parser> 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<examples/>. - -There's a wiki dedicated to the Test Anything Protocol: - -L<http://testanything.org> - -It includes the TAP::Parser Cookbook: - -L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook> - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $parser = TAP::Parser->new(\%args); - -Returns a new C<TAP::Parser> object. - -The arguments should be a hashref with I<one> of the following keys: - -=over 4 - -=item * C<source> - -This is the preferred method of passing arguments to the constructor. To -determine how to handle the source, the following steps are taken. - -If the source contains a newline, it's assumed to be a string of raw TAP -output. - -If the source is a reference, it's assumed to be something to pass to -the L<TAP::Parser::Iterator::Stream> constructor. This is used -internally and you should not use it. - -Otherwise, the parser does a C<-e> check to see if the source exists. If so, -it attempts to execute the source and read the output as a stream. This is by -far the preferred method of using the parser. - - foreach my $file ( @test_files ) { - my $parser = TAP::Parser->new( { source => $file } ); - # do stuff with the parser - } - -=item * C<tap> - -The value should be the complete TAP output. - -=item * C<exec> - -If passed an array reference, will attempt to create the iterator by -passing a L<TAP::Parser::Source> object to -L<TAP::Parser::Iterator::Source>, using the array reference strings as -the command arguments to L<IPC::Open3::open3|IPC::Open3>: - - exec => [ '/usr/bin/ruby', 't/my_test.rb' ] - -Note that C<source> and C<exec> are mutually exclusive. - -=back - -The following keys are optional. - -=over 4 - -=item * C<callback> - -If present, each callback corresponding to a given result type will be called -with the result as the argument if the C<run> 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; - foreach my $file ( @test_files ) { - my $parser = TAP::Parser->new( - { - source => $file, - callbacks => \%callbacks, - } - ); - $parser->run; - $aggregator->add( $file, $parser ); - } - -=item * C<switches> - -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<test_args> - -Used in conjunction with the C<source> option to supply a reference to -an C<@ARGV> style array of arguments to pass to the test program. - -=item * C<spool> - -If passed a filehandle will write a copy of all parsed TAP to that handle. - -=item * C<merge> - -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<source_class> - -This option was introduced to let you easily customize which I<source> class -the parser should use. It defaults to L<TAP::Parser::Source>. - -See also L</make_source>. - -=item * C<perl_source_class> - -This option was introduced to let you easily customize which I<perl source> -class the parser should use. It defaults to L<TAP::Parser::Source::Perl>. - -See also L</make_perl_source>. - -=item * C<grammar_class> - -This option was introduced to let you easily customize which I<grammar> class -the parser should use. It defaults to L<TAP::Parser::Grammar>. - -See also L</make_grammar>. - -=item * C<iterator_factory_class> - -This option was introduced to let you easily customize which I<iterator> -factory class the parser should use. It defaults to -L<TAP::Parser::IteratorFactory>. - -See also L</make_iterator>. - -=item * C<result_factory_class> - -This option was introduced to let you easily customize which I<result> -factory class the parser should use. It defaults to -L<TAP::Parser::ResultFactory>. - -See also L</make_result>. - -=back - -=cut - -# new() implementation supplied by TAP::Base - -# This should make overriding behaviour of the Parser in subclasses easier: -sub _default_source_class {'TAP::Parser::Source'} -sub _default_perl_source_class {'TAP::Parser::Source::Perl'} -sub _default_grammar_class {'TAP::Parser::Grammar'} -sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'} -sub _default_result_factory_class {'TAP::Parser::ResultFactory'} - -############################################################################## - -=head2 Instance Methods - -=head3 C<next> - - 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<TAP::Parser::Result>. 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<run> - - $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_source> - -Make a new L<TAP::Parser::Source> object and return it. Passes through any -arguments given. - -The C<source_class> can be customized, as described in L</new>. - -=head3 C<make_perl_source> - -Make a new L<TAP::Parser::Source::Perl> object and return it. Passes through -any arguments given. - -The C<perl_source_class> can be customized, as described in L</new>. - -=head3 C<make_grammar> - -Make a new L<TAP::Parser::Grammar> object and return it. Passes through any -arguments given. - -The C<grammar_class> can be customized, as described in L</new>. - -=head3 C<make_iterator> - -Make a new L<TAP::Parser::Iterator> object using the parser's -L<TAP::Parser::IteratorFactory>, and return it. Passes through any arguments -given. - -The C<iterator_factory_class> can be customized, as described in L</new>. - -=head3 C<make_result> - -Make a new L<TAP::Parser::Result> object using the parser's -L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments -given. - -The C<result_factory_class> can be customized, as described in L</new>. - -=cut - -# This should make overriding behaviour of the Parser in subclasses easier: -sub make_source { shift->source_class->new(@_); } -sub make_perl_source { shift->perl_source_class->new(@_); } -sub make_grammar { shift->grammar_class->new(@_); } -sub make_iterator { shift->iterator_factory_class->make_iterator(@_); } -sub make_result { shift->result_factory_class->make_result(@_); } - -sub _iterator_for_source { - my ( $self, $source ) = @_; - - # If the source has a get_stream method then use it. This makes it - # possible to pass a pre-existing source object to the parser's - # constructor. - if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) { - return $source->get_stream($self); - } - else { - return $self->iterator_factory_class->make_iterator($source); - } -} - -{ - - # of the following, anything beginning with an underscore is strictly - # internal and should not be exposed. - my %initialize = ( - version => $DEFAULT_TAP_VERSION, - plan => '', # the test plan (e.g., 1..3) - tap => '', # the TAP - tests_run => 0, # actual current test numbers - results => [], # TAP parser results - 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( - source_class - perl_source_class - grammar_class - iterator_factory_class - result_factory_class - ); - - sub _initialize { - my ( $self, $arg_for ) = @_; - - # everything here is basically designed to convert any TAP source to a - # stream. - - # 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 $stream = delete $args{stream}; - my $tap = delete $args{tap}; - my $source = delete $args{source}; - my $exec = delete $args{exec}; - my $merge = delete $args{merge}; - my $spool = delete $args{spool}; - my $switches = delete $args{switches}; - my $ignore_exit = delete $args{ignore_exit}; - my @test_args = @{ delete $args{test_args} || [] }; - - if ( 1 < grep {defined} $stream, $tap, $source, $exec ) { - $self->_croak( - "You may only choose one of 'exec', 'stream', 'tap' or 'source'" - ); - } - - if ( my @excess = sort keys %args ) { - $self->_croak("Unknown options: @excess"); - } - - if ($tap) { - $stream = $self->_iterator_for_source( [ split "\n" => $tap ] ); - } - elsif ($exec) { - my $source = $self->make_source; - $source->source( [ @$exec, @test_args ] ); - $source->merge($merge); # XXX should just be arguments? - $stream = $source->get_stream($self); - } - elsif ($source) { - if ( $source =~ /\n/ ) { - $stream - = $self->_iterator_for_source( [ split "\n" => $source ] ); - } - elsif ( ref $source ) { - $stream = $self->_iterator_for_source($source); - } - elsif ( -e $source ) { - my $perl = $self->make_perl_source; - - $perl->switches($switches) - if $switches; - - $perl->merge($merge); # XXX args to new()? - $perl->source( [ $source, @test_args ] ); - $stream = $perl->get_stream($self); - } - else { - $self->_croak("Cannot determine source for $source"); - } - } - - unless ($stream) { - $self->_croak('PANIC: could not determine stream'); - } - - while ( my ( $k, $v ) = each %initialize ) { - $self->{$k} = 'ARRAY' eq ref $v ? [] : $v; - } - - $self->_stream($stream); - $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<TAP::Parser::Result> subclass, referred to as -I<result types>. - -=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<type> - -Returns the type of result, such as C<comment> or C<test>. - -=head3 C<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<raw> method. - -=head3 C<raw> - -Returns the original line of text which was parsed. - -=head3 C<is_plan> - -Indicates whether or not this is the test plan line. - -=head3 C<is_test> - -Indicates whether or not this is a test line. - -=head3 C<is_comment> - -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<merge> option. - -=head3 C<is_bailout> - -Indicates whether or not this is bailout line. - -=head3 C<is_yaml> - -Indicates whether or not the current item is a YAML block. - -=head3 C<is_unknown> - -Indicates whether or not the current line could be parsed. - -=head3 C<is_ok> - - if ( $result->is_ok ) { ... } - -Reports whether or not a given result has passed. Anything which is B<not> 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<plan> methods - - if ( $result->is_plan ) { ... } - -If the above evaluates as true, the following methods will be available on the -C<$result> object. - -=head3 C<plan> - - if ( $result->is_plan ) { - print $result->plan; - } - -This is merely a synonym for C<as_string>. - -=head3 C<directive> - - 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<explanation> - - my $explanation = $result->explanation; - -If a SKIP directive was included with the plan, this method will return the -explanation, if any. - -=head2 C<pragma> methods - - if ( $result->is_pragma ) { ... } - -If the above evaluates as true, the following methods will be available on the -C<$result> object. - -=head3 C<pragmas> - -Returns a list of pragmas each of which is a + or - followed by the -pragma name. - -=head2 C<commment> methods - - if ( $result->is_comment ) { ... } - -If the above evaluates as true, the following methods will be available on the -C<$result> object. - -=head3 C<comment> - - if ( $result->is_comment ) { - my $comment = $result->comment; - print "I have something to say: $comment"; - } - -=head2 C<bailout> methods - - if ( $result->is_bailout ) { ... } - -If the above evaluates as true, the following methods will be available on the -C<$result> object. - -=head3 C<explanation> - - 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<unknown> methods - - if ( $result->is_unknown ) { ... } - -There are no unique methods for unknown results. - -=head2 C<test> methods - - if ( $result->is_test ) { ... } - -If the above evaluates as true, the following methods will be available on the -C<$result> object. - -=head3 C<ok> - - my $ok = $result->ok; - -Returns the literal text of the C<ok> or C<not ok> status. - -=head3 C<number> - - my $test_number = $result->number; - -Returns the number of the test, even if the original TAP output did not supply -that number. - -=head3 C<description> - - 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<directive> - - my $directive = $result->directive; - -Returns either C<TODO> or C<SKIP> if either directive was present for a test -line. - -=head3 C<explanation> - - my $explanation = $result->explanation; - -If a test had either a C<TODO> or C<SKIP> directive, this method will return -the accompanying explantion, if present. - - not ok 17 - 'Pigs can fly' # TODO not enough acid - -For the above line, the explanation is I<not enough acid>. - -=head3 C<is_ok> - - 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<Note:> this was formerly C<passed>. The latter method is deprecated and -will issue a warning. - -=head3 C<is_actual_ok> - - if ( $result->is_actual_ok ) { ... } - -Returns a boolean value indicating whether or not the test passed, regardless -of its TODO status. - -B<Note:> this was formerly C<actual_passed>. The latter method is deprecated -and will issue a warning. - -=head3 C<is_unplanned> - - 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<always> return false for C<is_ok>, -regardless of whether or not the test C<has_todo> (see -L<TAP::Parser::Result::Test> for more information about this). - -=head3 C<has_skip> - - if ( $result->has_skip ) { ... } - -Returns a boolean value indicating whether or not this test had a SKIP -directive. - -=head3 C<has_todo> - - if ( $result->has_todo ) { ... } - -Returns a boolean value indicating whether or not this test had a TODO -directive. - -Note that TODO tests I<always> pass. If you need to know whether or not -they really passed, check the C<is_actual_ok> method. - -=head3 C<in_todo> - - 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<passed> - - 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 { @{ shift->{passed} } } - -=head3 C<failed> - - 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<NOT> be counted as a failed test. - -=cut - -sub failed { @{ shift->{failed} } } - -=head3 C<actual_passed> - - # 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 { @{ shift->{actual_passed} } } -*actual_ok = \&actual_passed; - -=head3 C<actual_ok> - -This method is a synonym for C<actual_passed>. - -=head3 C<actual_failed> - - # 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<todo> - - 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<todo_passed> - - # 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<todo_failed> - - # 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<todo_passed>. - -=cut - -sub todo_failed { - warn - '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; - goto &todo_passed; -} - -=head3 C<skipped> - - 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<pragma> - -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<pragmas> - -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<plan> - - my $plan = $parser->plan; - -Returns the test plan, if found. - -=head3 C<good_plan> - -Deprecated. Use C<is_good_plan> instead. - -=cut - -sub good_plan { - warn 'good_plan() is deprecated. Please use "is_good_plan()"'; - goto &is_good_plan; -} - -############################################################################## - -=head3 C<is_good_plan> - - 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<Note:> this was formerly C<good_plan>. The latter method is deprecated and -will issue a warning. - -And since we're on that subject ... - -=head3 C<tests_planned> - - 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<tests_run> - - 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<skip_all> - -Returns a true value (actually the reason for skipping) if all tests -were skipped. - -=head3 C<start_time> - -Returns the time when the Parser was created. - -=head3 C<end_time> - -Returns the time when the end of TAP input was seen. - -=head3 C<has_problems> - - 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<version> - - $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<exit> - - $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<wait> - - $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 -mererely returns the C<exit> status. - -=head2 C<ignore_exit> - - $parser->ignore_exit(1); - -Tell the parser to ignore the exit status from the test when determining -whether the test passed. Normally tests with non-zero exit status are -considered to have failed even if all individual tests passed. In cases -where it is not possible to control the exit value of the test script -use this option to ignore it. - -=cut - -sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) } - -=head3 C<parse_errors> - - my @errors = $parser->parse_errors; # the parser errors - 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<not> 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 => 'PLANNED' }, - }, - ); - - # 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_select_handles> - -Get an a list of file handles which can be passed to C<select> to -determine the readiness of this parser. - -=cut - -sub get_select_handles { shift->_stream->get_select_handles } - -sub _grammar { - my $self = shift; - return $self->{_grammar} = shift if @_; - - return $self->{_grammar} ||= $self->make_grammar( - { stream => $self->_stream, - parser => $self, - version => $self->version - } - ); -} - -sub _iter { - my $self = shift; - my $stream = $self->_stream; - my $grammar = $self->_grammar; - my $spool = $self->_spool; - my $state = 'INIT'; - my $state_table = $self->_make_state_table; - - $self->start_time( $self->get_time ); - - # Make next_state closure - my $next_state = sub { - my $token = shift; - my $type = $token->type; - TRANS: { - my $state_spec = $state_table->{$state} - or die "Illegal state: $state"; - - if ( my $next = $state_spec->{$type} ) { - if ( my $act = $next->{act} ) { - $act->($token); - } - if ( my $cont = $next->{continue} ) { - $state = $cont; - redo TRANS; - } - elsif ( my $goto = $next->{goto} ) { - $state = $goto; - } - } - else { - confess("Unhandled token type: $type\n"); - } - } - return $token; - }; - - # Handle end of stream - which means either pop a block or finish - my $end_handler = sub { - $self->exit( $stream->exit ); - $self->wait( $stream->wait ); - $self->_finish; - return; - }; - - # Finally make the closure that we return. For performance reasons - # there are two versions of the returned function: one that handles - # callbacks and one that does not. - if ( $self->_has_callbacks ) { - return sub { - my $result = eval { $grammar->tokenize }; - $self->_add_error($@) if $@; - - if ( defined $result ) { - $result = $next_state->($result); - - if ( my $code = $self->_callback_for( $result->type ) ) { - $_->($result) for @{$code}; - } - else { - $self->_make_callback( 'ELSE', $result ); - } - - $self->_make_callback( 'ALL', $result ); - - # Echo TAP to spool file - print {$spool} $result->raw, "\n" if $spool; - } - else { - $result = $end_handler->(); - $self->_make_callback( 'EOF', $self ) - unless defined $result; - } - - return $result; - }; - } # _has_callbacks - else { - return sub { - my $result = eval { $grammar->tokenize }; - $self->_add_error($@) if $@; - - if ( defined $result ) { - $result = $next_state->($result); - - # Echo TAP to spool file - print {$spool} $result->raw, "\n" if $spool; - } - else { - $result = $end_handler->(); - } - - return $result; - }; - } # no callbacks -} - -sub _finish { - my $self = shift; - - $self->end_time( $self->get_time ); - - # Avoid leaks - $self->_stream(undef); - $self->_grammar(undef); - - # If we just delete the iter we won't get a fault if it's recreated. - # Instead we set it to a sub that returns an infinite - # stream of undef. This segfaults on 5.5.4, presumably because - # we're still executing the closure that gets replaced and it hasn't - # been protected with a refcount. - $self->{_iter} = sub {return} - if $] >= 5.006; - - # sanity checks - if ( !$self->plan ) { - $self->_add_error('No plan found in TAP output'); - } - else { - $self->is_good_plan(1) unless defined $self->is_good_plan; - } - if ( $self->tests_run != ( $self->tests_planned || 0 ) ) { - $self->is_good_plan(0); - if ( defined( my $planned = $self->tests_planned ) ) { - my $ran = $self->tests_run; - $self->_add_error( - "Bad plan. You planned $planned tests but ran $ran."); - } - } - if ( $self->tests_run != ( $self->passed + $self->failed ) ) { - - # this should never happen - my $actual = $self->tests_run; - my $passed = $self->passed; - my $failed = $self->failed; - $self->_croak( "Panic: planned test count ($actual) did not equal " - . "sum of passed ($passed) and failed ($failed) tests!" ); - } - - $self->is_good_plan(0) unless defined $self->is_good_plan; - return $self; -} - -=head3 C<delete_spool> - -Delete and return the spool. - - my $fh = $parser->delete_spool; - -=cut - -sub delete_spool { - my $self = shift; - - return delete $self->{_spool}; -} - -############################################################################## - -=head1 CALLBACKS - -As mentioned earlier, a "callback" key may be added to the -C<TAP::Parser> constructor. If present, each callback corresponding to a -given result type will be called with the result as the argument if the -C<run> method is used. The callback is expected to be a subroutine -reference (or anonymous subroutine) which is invoked with the parser -result as its argument. - - my %callbacks = ( - test => \&test_callback, - plan => \&plan_callback, - comment => \&comment_callback, - bailout => \&bailout_callback, - unknown => \&unknown_callback, - ); - - my $aggregator = TAP::Parser::Aggregator->new; - foreach my $file ( @test_files ) { - my $parser = TAP::Parser->new( - { - source => $file, - callbacks => \%callbacks, - } - ); - $parser->run; - $aggregator->add( $file, $parser ); - } - -Callbacks may also be added like this: - - $parser->callback( test => \&test_callback ); - $parser->callback( plan => \&plan_callback ); - -The following keys allowed for callbacks. These keys are case-sensitive. - -=over 4 - -=item * C<test> - -Invoked if C<< $result->is_test >> returns true. - -=item * C<version> - -Invoked if C<< $result->is_version >> returns true. - -=item * C<plan> - -Invoked if C<< $result->is_plan >> returns true. - -=item * C<comment> - -Invoked if C<< $result->is_comment >> returns true. - -=item * C<bailout> - -Invoked if C<< $result->is_unknown >> returns true. - -=item * C<yaml> - -Invoked if C<< $result->is_yaml >> returns true. - -=item * C<unknown> - -Invoked if C<< $result->is_unknown >> returns true. - -=item * C<ELSE> - -If a result does not have a callback defined for it, this callback will -be invoked. Thus, if all of the previous result types are specified as -callbacks, this callback will I<never> be invoked. - -=item * C<ALL> - -This callback will always be invoked and this will happen for each -result after one of the above callbacks is invoked. For example, if -L<Term::ANSIColor> is loaded, you could use the following to color your -test output: - - my %callbacks = ( - test => sub { - my $test = shift; - if ( $test->is_ok && not $test->directive ) { - # normal passing test - print color 'green'; - } - elsif ( !$test->is_ok ) { # even if it's TODO - print color 'white on_red'; - } - elsif ( $test->has_skip ) { - print color 'white on_blue'; - - } - elsif ( $test->has_todo ) { - print color 'white'; - } - }, - ELSE => sub { - # plan, comment, and so on (anything which isn't a test line) - print color 'black on_white'; - }, - ALL => sub { - # now print them - print shift->as_string; - print color 'reset'; - print "\n"; - }, - ); - -=item * C<EOF> - -Invoked when there are no more lines to be parsed. Since there is no -accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is -passed instead. - -=back - -=head1 TAP GRAMMAR - -If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>. - -=head1 BACKWARDS COMPATABILITY - -The Perl-QA list attempted to ensure backwards compatability with -L<Test::Harness>. However, there are some minor differences. - -=head2 Differences - -=over 4 - -=item * TODO plans - -A little-known feature of L<Test::Harness> is that it supported TODO -lists in the plan: - - 1..2 todo 2 - ok 1 - We have liftoff - not ok 2 - Anti-gravity device activated - -Under L<Test::Harness>, test number 2 would I<pass> because it was -listed as a TODO test on the plan line. However, we are not aware of -anyone actually using this feature and hard-coding test numbers is -discouraged because it's very easy to add a test and break the test -number sequence. This makes test suites very fragile. Instead, the -following should be used: - - 1..2 - ok 1 - We have liftoff - not ok 2 - Anti-gravity device activated # TODO - -=item * 'Missing' tests - -It rarely happens, but sometimes a harness might encounter -'missing tests: - - ok 1 - ok 2 - ok 15 - ok 16 - ok 17 - -L<Test::Harness> would report tests 3-14 as having failed. For the -C<TAP::Parser>, these tests are not considered failed because they've -never run. They're reported as parse failures (tests out of sequence). - -=back - -=head1 SUBCLASSING - -If you find you need to provide custom functionality (as you would have using -L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are -designed to be easily subclassed. - -Before you start, it's important to know a few things: - -=over 2 - -=item 1 - -All C<TAP::*> objects inherit from L<TAP::Object>. - -=item 2 - -Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you. - -=item 3 - -Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is -responsible for creating new objects in the C<TAP::Parser::*> namespace. - -This makes it possible for you to have a single point of configuring what -subclasses should be used, which in turn means that in many cases you'll find -you only need to sub-class one of the parser's components. - -=item 4 - -By subclassing, you may end up overriding undocumented methods. That's not -a bad thing per se, but be forewarned that undocumented methods may change -without warning from one release to the next - we cannot guarantee backwards -compatability. If any I<documented> method needs changing, it will be -deprecated first, and changed in a later release. - -=back - -=head2 Parser Components - -=head3 Sources - -A TAP parser consumes input from a I<source>. There are currently two types -of sources: L<TAP::Parser::Source> for general non-perl commands, and -L<TAP::Parser::Source::Perl>. You can subclass both of them. You'll need to -customize your parser by setting the C<source_class> & C<perl_source_class> -parameters. See L</new> for more details. - -If you need to customize the objects on creation, subclass L<TAP::Parser> and -override L</make_source> or L</make_perl_source>. - -=head3 Iterators - -A TAP parser uses I<iterators> to loop through the I<stream> provided by the -parser's I<source>. There are quite a few types of Iterators available. -Choosing which class to use is the responsibility of the I<iterator factory>. - -To create your own iterators you'll have to subclass -L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>. Then you'll -need to customize the class used by your parser by setting the -C<iterator_factory_class> parameter. See L</new> for more details. - -If you need to customize the objects on creation, subclass L<TAP::Parser> and -override L</make_iterator>. - -=head3 Results - -A TAP parser creates L<TAP::Parser::Result>s as it iterates through the -input I<stream>. There are quite a few result types available; choosing -which class to use is the responsibility of the I<result factory>. - -To create your own result types you have two options: - -=over 2 - -=item option 1 - -Subclass L<TAP::Parser::Result> and register your new result type/class with -the default L<TAP::Parser::ResultFactory>. - -=item option 2 - -Subclass L<TAP::Parser::ResultFactory> itself and implement your own -L<TAP::Parser::Result> creation logic. Then you'll need to customize the -class used by your parser by setting the C<result_factory_class> parameter. -See L</new> for more details. - -=back - -If you need to customize the objects on creation, subclass L<TAP::Parser> and -override L</make_result>. - -=head3 Grammar - -L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP -input I<stream> and produces results. If you need to customize its behaviour -you should probably familiarize yourself with the source first. Enough -lecturing. - -Subclass L<TAP::Parser::Grammar> and customize your parser by setting the -C<grammar_class> parameter. See L</new> for more details. - -If you need to customize the objects on creation, subclass L<TAP::Parser> and -override L</make_grammar> - -=head1 ACKNOWLEDGEMENTS - -All of the following have helped. Bug reports, patches, (im)moral -support, or just words of encouragement have all been forthcoming. - -=over 4 - -=item * Michael Schwern - -=item * Andy Lester - -=item * chromatic - -=item * GEOFFR - -=item * Shlomi Fish - -=item * Torsten Schoenfeld - -=item * Jerry Gay - -=item * Aristotle - -=item * Adam Kennedy - -=item * Yves Orton - -=item * Adrian Howard - -=item * Sean & Lil - -=item * Andreas J. Koenig - -=item * Florian Ragwitz - -=item * Corion - -=item * Mark Stosberg - -=item * Matt Kraai - -=item * David Wheeler - -=item * Alex Vandiver - -=back - -=head1 AUTHORS - -Curtis "Ovid" Poe <ovid@cpan.org> - -Andy Armstong <andy@hexten.net> - -Eric Wilhelm @ <ewilhelm at cpan dot org> - -Michael Peters <mpeters at plusthree dot com> - -Leif Eriksen <leif dot eriksen at bigpond dot com> - -Steve Purkis <spurkis@cpan.org> - -Nicholas Clark <nick@ccl4.org> - -=head1 BUGS - -Please report any bugs or feature requests to -C<bug-test-harness@rt.cpan.org>, or through the web interface at -L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. -We will be notified, and then you'll automatically be notified of -progress on your bug as we make changes. - -Obviously, bugs which include patches are best. If you prefer, you can -patch against bleed by via anonymous checkout of the latest version: - - svn checkout http://svn.hexten.net/tapx - -=head1 COPYRIGHT & LICENSE - -Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Aggregator.pm b/ext/Test-Harness/lib/TAP/Parser/Aggregator.pm deleted file mode 100644 index 10b37ef72a..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Aggregator.pm +++ /dev/null @@ -1,416 +0,0 @@ -package TAP::Parser::Aggregator; - -use strict; -use Benchmark; -use vars qw($VERSION @ISA); - -use TAP::Object (); - -@ISA = qw(TAP::Object); - -=head1 NAME - -TAP::Parser::Aggregator - Aggregate TAP::Parser results - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=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<TAP::Parser::Aggregator> collects parser objects and allows -reporting/querying their aggregate results. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $aggregate = TAP::Parser::Aggregator->new; - -Returns a new C<TAP::Parser::Aggregator> 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'; - - foreach 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} = []; - foreach 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<add> - - $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<TAP::Parser|TAP::Parser> 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<parsers> - - 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; - foreach 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<descriptions> - -Get an array of descriptions in the order in which they were added to -the aggregator. - -=cut - -sub descriptions { @{ shift->{parse_order} || [] } } - -=head3 C<start> - -Call C<start> 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<stop> - -Call C<stop> immediately after adding all test results to the aggregator. - -=cut - -sub stop { - my $self = shift; - $self->{end_time} = Benchmark->new; -} - -=head3 C<elapsed> - -Elapsed returns a L<Benchmark> object that represents the running time -of the aggregated tests. In order for C<elapsed> to be valid you must -call C<start> before running the tests and C<stop> 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<elapsed_timestr> - -Returns a formatted string representing the runtime returned by -C<elapsed()>. This lets the caller not worry about Benchmark. - -=cut - -sub elapsed_timestr { - my $self = shift; - - my $elapsed = $self->elapsed; - - return timestr($elapsed); -} - -=head3 C<all_passed> - -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_status> - -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<CPAN::Reporter>. - -=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<add> -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<wait> and C<exit> 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<total> - - my $tests_run = $aggregate->total; - -Returns the total number of tests run. - -=cut - -sub total { shift->{total} } - -############################################################################## - -=head3 C<has_problems> - - if ( $parser->has_problems ) { - ... - } - -Identical to C<has_errors>, 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<has_errors> - - if ( $parser->has_errors ) { - ... - } - -Returns true if I<any> 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<todo_failed> - - # 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<todo_passed>. - -=cut - -sub todo_failed { - warn - '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; - goto &todo_passed; -} - -=head1 See Also - -L<TAP::Parser> - -L<TAP::Harness> - -=cut - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Grammar.pm b/ext/Test-Harness/lib/TAP/Parser/Grammar.pm deleted file mode 100644 index 44f28a0491..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Grammar.pm +++ /dev/null @@ -1,580 +0,0 @@ -package TAP::Parser::Grammar; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); -use TAP::Parser::ResultFactory (); -use TAP::Parser::YAMLish::Reader (); - -@ISA = qw(TAP::Object); - -=head1 NAME - -TAP::Parser::Grammar - A grammar for the Test Anything Protocol. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Grammar; - my $grammar = $self->make_grammar({ - stream => $tap_parser_stream, - parser => $tap_parser, - version => 12, - }); - - my $result = $grammar->tokenize; - -=head1 DESCRIPTION - -C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs -L<TAP::Parser::Result> subclasses to represent the tokens. - -Do not attempt to use this class directly. It won't make sense. It's mainly -here to ensure that we will be able to have pluggable grammars when TAP is -expanded at some future date (plus, this stuff was really cluttering the -parser). - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $grammar = TAP::Parser::Grammar->new({ - stream => $stream, - parser => $parser, - version => $version, - }); - -Returns L<TAP::Parser> grammar object that will parse the specified stream. -Both C<stream> and C<parser> are required arguments. If C<version> is not set -it defaults to C<12> (see L</set_version> for more details). - -=cut - -# new() implementation supplied by TAP::Object -sub _initialize { - my ( $self, $args ) = @_; - $self->{stream} = $args->{stream}; # TODO: accessor - $self->{parser} = $args->{parser}; # TODO: accessor - $self->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/^Bail out!\s*(.*)/, - handler => sub { - my ( $self, $line ) = @_; - my $explanation = $1; - return $self->_make_bailout_token( - $line, - $explanation - ); - }, - }, - ); - - my %v13 = ( - %v12, - plan => { - syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i, - handler => sub { - my ( $self, $line ) = @_; - my ( $tests_planned, $explanation ) = ( $1, $2 ); - my $skip - = ( 0 == $tests_planned || defined $explanation ) - ? 'SKIP' - : ''; - $explanation = '' unless defined $explanation; - return $self->_make_plan_token( - $line, $tests_planned, $skip, - $explanation, [] - ); - }, - }, - yaml => { - syntax => qr/^ (\s+) (---.*) $/x, - handler => sub { - my ( $self, $line ) = @_; - my ( $pad, $marker ) = ( $1, $2 ); - return $self->_make_yaml_token( $pad, $marker ); - }, - }, - pragma => { - syntax => - qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x, - handler => sub { - my ( $self, $line ) = @_; - my $pragmas = $1; - return $self->_make_pragma_token( $line, $pragmas ); - }, - }, - ); - - %language_for = ( - '12' => { - tokens => \%v12, - }, - '13' => { - tokens => \%v13, - setup => sub { - shift->{stream}->handle_unicode; - }, - }, - ); -} - -############################################################################## - -=head2 Instance Methods - -=head3 C<set_version> - - $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<tokenize> - - my $token = $grammar->tokenize; - -This method will return a L<TAP::Parser::Result> object representing the -current line of TAP. - -=cut - -sub tokenize { - my $self = shift; - - my $line = $self->{stream}->next; - unless ( defined $line ) { - delete $self->{parser}; # break circular ref - return; - } - - my $token; - - foreach 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<token_types> - - 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<syntax_for> - - 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<handler_for> - - 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 ) ) { - foreach 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, - test_num => $num, - 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 $stream = $self->{stream}; - - # 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 = $stream->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<NOTE:> 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<TAP::Parser> 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 compatability, any result which does not match the -following grammar is currently referred to as -L<TAP::Parser::Result::Unknown>. It is I<not> 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<TAP::Parser/SUBCLASSING> for a subclassing overview. - -If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to -do is read through the code. There's no easy way of summarizing it here. - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Iterator>, -L<TAP::Parser::Result>, - -=cut diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator.pm deleted file mode 100644 index 09d40bebcc..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator.pm +++ /dev/null @@ -1,165 +0,0 @@ -package TAP::Parser::Iterator; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); - -@ISA = qw(TAP::Object); - -=head1 NAME - -TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - # see TAP::Parser::IteratorFactory for general usage - - # to subclass: - use vars qw(@ISA); - use TAP::Parser::Iterator (); - @ISA = qw(TAP::Parser::Iterator); - sub _initialize { - # see TAP::Object... - } - -=head1 DESCRIPTION - -This is a simple iterator base class that defines L<TAP::Parser>'s iterator -API. See C<TAP::Parser::IteratorFactory> for the preferred way of creating -iterators. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -Create an iterator. Provided by L<TAP::Object>. - -=head2 Instance Methods - -=head3 C<next> - - while ( my $item = $iter->next ) { ... } - -Iterate through it, of course. - -=head3 C<next_raw> - -B<Note:> this method is abstract and should be overridden. - - while ( my $item = $iter->next_raw ) { ... } - -Iterate raw input without applying any fixes for quirky input syntax. - -=cut - -sub 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<handle_unicode> - -If necessary switch the input stream to handle unicode. This only has -any effect for I/O handle based streams. - -The default implementation does nothing. - -=cut - -sub handle_unicode { } - -=head3 C<get_select_handles> - -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<wait> - -B<Note:> this method is abstract and should be overridden. - - my $wait_status = $iter->wait; - -Return the C<wait> status for this iterator. - -=head3 C<exit> - -B<Note:> this method is abstract and should be overridden. - - my $wait_status = $iter->exit; - -Return the C<exit> status for this iterator. - -=cut - -sub wait { - require Carp; - my $msg = Carp::longmess('abstract method called directly!'); - $_[0]->_croak($msg); -} - -sub exit { - require Carp; - my $msg = Carp::longmess('abstract method called directly!'); - $_[0]->_croak($msg); -} - -1; - -=head1 SUBCLASSING - -Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. - -You must override the abstract methods as noted above. - -=head2 Example - -L<TAP::Parser::Iterator::Array> is probably the easiest example to follow. -There's not much point repeating it here. - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::IteratorFactory>, -L<TAP::Parser::Iterator::Array>, -L<TAP::Parser::Iterator::Stream>, -L<TAP::Parser::Iterator::Process>, - -=cut - diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm deleted file mode 100644 index 1513d5b994..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm +++ /dev/null @@ -1,106 +0,0 @@ -package TAP::Parser::Iterator::Array; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Parser::Iterator (); - -@ISA = 'TAP::Parser::Iterator'; - -=head1 NAME - -TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - # see TAP::Parser::IteratorFactory for preferred usage - - # to use directly: - use TAP::Parser::Iterator::Array; - my @data = ('foo', 'bar', baz'); - my $it = TAP::Parser::Iterator::Array->new(\@data); - my $line = $it->next; - -=head1 DESCRIPTION - -This is a simple iterator wrapper for arrays of scalar content, used by -L<TAP::Parser>. Unless you're subclassing, you probably won't need to use -this module directly. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -Create an iterator. Takes one argument: an C<$array_ref> - -=head2 Instance Methods - -=head3 C<next> - -Iterate through it, of course. - -=head3 C<next_raw> - -Iterate raw input without applying any fixes for quirky input syntax. - -=head3 C<wait> - -Get the wait status for this iterator. For an array iterator this will always -be zero. - -=head3 C<exit> - -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<Test::Harness>. - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, - -=cut - diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm deleted file mode 100644 index a0a5a8ed32..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm +++ /dev/null @@ -1,377 +0,0 @@ -package TAP::Parser::Iterator::Process; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Parser::Iterator (); -use Config; -use IO::Handle; - -@ISA = 'TAP::Parser::Iterator'; - -my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); - -=head1 NAME - -TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - # see TAP::Parser::IteratorFactory for preferred usage - - # to use directly: - use TAP::Parser::Iterator::Process; - my %args = ( - command => ['python', 'setup.py', 'test'], - merge => 1, - setup => sub { ... }, - teardown => sub { ... }, - ); - my $it = TAP::Parser::Iterator::Process->new(\%args); - my $line = $it->next; - -=head1 DESCRIPTION - -This is a simple iterator wrapper for executing external processes, used by -L<TAP::Parser>. Unless you're subclassing, you probably won't need to use -this module directly. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -Create an iterator. Expects one argument containing a hashref of the form: - - command => \@command_to_execute - merge => $attempt_merge_stderr_and_stdout? - setup => $callback_to_setup_command - teardown => $callback_to_teardown_command - -Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned -process if they are available. Falls back onto C<open()>. - -=head2 Instance Methods - -=head3 C<next> - -Iterate through the process output, of course. - -=head3 C<next_raw> - -Iterate raw input without applying any fixes for quirky input syntax. - -=head3 C<wait> - -Get the wait status for this iterator's process. - -=head3 C<exit> - -Get the exit status for this iterator's process. - -=cut - -eval { require POSIX; &POSIX::WEXITSTATUS(0) }; -if ($@) { - *_wait2exit = sub { $_[1] >> 8 }; -} -else { - *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) } -} - -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"; - - # 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; - local $^W; # 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 ) { - - # Kludge to avoid warning under 5.5 - eval 'binmode($out, ":crlf")'; - } - } - else { - $err = $merge ? '' : IO::Handle->new; - eval { $pid = open3( '<&STDIN', $out, $err, @command ); }; - die "Could not execute (@command): $@" if $@; - $sel = $merge ? undef : IO::Select->new( $out, $err ); - } - } - else { - $err = ''; - my $command - = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command ); - open( $out, "$command|" ) - or die "Could not execute ($command): $!"; - } - - $self->{out} = $out; - $self->{err} = $err; - $self->{sel} = $sel; - $self->{pid} = $pid; - $self->{exit} = undef; - $self->{chunk_size} = $chunk_size; - - if ( my $teardown = delete $args->{teardown} ) { - $self->{teardown} = sub { - $teardown->(@command); - }; - } - - return $self; -} - -=head3 C<handle_unicode> - -Upgrade the input stream to handle UTF8. - -=cut - -sub handle_unicode { - my $self = shift; - - if ( $self->{sel} ) { - if ( _get_unicode() ) { - - # Make sure our iterator has been constructed and... - my $next = $self->{_next} ||= $self->_next; - - # ...wrap it to do UTF8 casting - $self->{_next} = sub { - my $line = $next->(); - return decode_utf8($line) if defined $line; - return; - }; - } - } - else { - if ( $] >= 5.008 ) { - eval 'binmode($self->{out}, ":utf8")'; - } - } - -} - -############################################################################## - -sub wait { shift->{wait} } -sub exit { shift->{exit} } - -sub _next { - my $self = shift; - - if ( my $out = $self->{out} ) { - if ( my $sel = $self->{sel} ) { - my $err = $self->{err}; - my @buf = (); - my $partial = ''; # Partial line - my $chunk_size = $self->{chunk_size}; - return sub { - return shift @buf if @buf; - - READ: - while ( my @ready = $sel->can_read ) { - for my $fh (@ready) { - my $got = sysread $fh, my ($chunk), $chunk_size; - - if ( $got == 0 ) { - $sel->remove($fh); - } - elsif ( $fh == $err ) { - print STDERR $chunk; # echo STDERR - } - else { - $chunk = $partial . $chunk; - $partial = ''; - - # Make sure we have a complete line - unless ( substr( $chunk, -1, 1 ) eq "\n" ) { - my $nl = rindex $chunk, "\n"; - if ( $nl == -1 ) { - $partial = $chunk; - redo READ; - } - else { - $partial = substr( $chunk, $nl + 1 ); - $chunk = substr( $chunk, 0, $nl ); - } - } - - push @buf, split /\n/, $chunk; - return shift @buf if @buf; - } - } - } - - # Return partial last line - if ( length $partial ) { - my $last = $partial; - $partial = ''; - return $last; - } - - $self->_finish; - return; - }; - } - else { - return sub { - if ( defined( my $line = <$out> ) ) { - chomp $line; - return $line; - } - $self->_finish; - return; - }; - } - } - else { - return sub { - $self->_finish; - return; - }; - } -} - -sub next_raw { - my $self = shift; - return ( $self->{_next} ||= $self->_next )->(); -} - -sub _finish { - my $self = shift; - - my $status = $?; - - # Avoid circular refs - $self->{_next} = sub {return} - if $] >= 5.006; - - # If we have a subprocess we need to wait for it to terminate - if ( defined $self->{pid} ) { - if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) { - $status = $?; - } - } - - ( delete $self->{out} )->close if $self->{out}; - - # If we have an IO::Select we also have an error handle to close. - if ( $self->{sel} ) { - ( delete $self->{err} )->close; - delete $self->{sel}; - } - else { - $status = $?; - } - - # Sometimes we get -1 on Windows. Presumably that means status not - # available. - $status = 0 if $IS_WIN32 && $status == -1; - - $self->{wait} = $status; - $self->{exit} = $self->_wait2exit($status); - - if ( my $teardown = $self->{teardown} ) { - $teardown->(); - } - - return $self; -} - -=head3 C<get_select_handles> - -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<Test::Harness>. - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, - -=cut - diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm deleted file mode 100644 index c92cbabe08..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm +++ /dev/null @@ -1,112 +0,0 @@ -package TAP::Parser::Iterator::Stream; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Parser::Iterator (); - -@ISA = 'TAP::Parser::Iterator'; - -=head1 NAME - -TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - # see TAP::Parser::IteratorFactory for preferred usage - - # to use directly: - use TAP::Parser::Iterator::Stream; - open( TEST, 'test.tap' ); - my $it = TAP::Parser::Iterator::Stream->new(\*TEST); - my $line = $it->next; - -=head1 DESCRIPTION - -This is a simple iterator wrapper for reading from filehandles, used by -L<TAP::Parser>. Unless you're subclassing, you probably won't need to use -this module directly. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -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<next> - -Iterate through it, of course. - -=head3 C<next_raw> - -Iterate raw input without applying any fixes for quirky input syntax. - -=head3 C<wait> - -Get the wait status for this iterator. Always returns zero. - -=head3 C<exit> - -Get the exit status for this iterator. Always returns zero. - -=cut - -sub wait { shift->exit } -sub exit { shift->{fh} ? () : 0 } - -sub next_raw { - my $self = shift; - my $fh = $self->{fh}; - - if ( defined( my $line = <$fh> ) ) { - chomp $line; - return $line; - } - else { - $self->_finish; - return; - } -} - -sub _finish { - my $self = shift; - close delete $self->{fh}; -} - -1; - -=head1 ATTRIBUTION - -Originally ripped off from L<Test::Harness>. - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, - -=cut - diff --git a/ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm deleted file mode 100644 index 064d7beb16..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm +++ /dev/null @@ -1,171 +0,0 @@ -package TAP::Parser::IteratorFactory; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); -use TAP::Parser::Iterator::Array (); -use TAP::Parser::Iterator::Stream (); -use TAP::Parser::Iterator::Process (); - -@ISA = qw(TAP::Object); - -=head1 NAME - -TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::IteratorFactory; - my $factory = TAP::Parser::IteratorFactory->new; - my $iter = $factory->make_iterator(\*TEST); - my $iter = $factory->make_iterator(\@array); - my $iter = $factory->make_iterator(\%hash); - - my $line = $iter->next; - -=head1 DESCRIPTION - -This is a factory class for simple iterator wrappers for arrays, filehandles, -and hashes. Unless you're subclassing, you probably won't need to use this -module directly. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -Creates a new factory class. -I<Note:> You currently don't need to instantiate a factory in order to use it. - -=head3 C<make_iterator> - -Create an iterator. The type of iterator created depends on the arguments to -the constructor: - - my $iter = TAP::Parser::Iterator->make_iterator( $filehandle ); - -Creates a I<stream> iterator (see L</make_stream_iterator>). - - my $iter = TAP::Parser::Iterator->make_iterator( $array_reference ); - -Creates an I<array> iterator (see L</make_array_iterator>). - - my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference ); - -Creates a I<process> iterator (see L</make_process_iterator>). - -=cut - -sub make_iterator { - my ( $proto, $thing ) = @_; - - my $ref = ref $thing; - if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) { - return $proto->make_stream_iterator($thing); - } - elsif ( $ref eq 'ARRAY' ) { - return $proto->make_array_iterator($thing); - } - elsif ( $ref eq 'HASH' ) { - return $proto->make_process_iterator($thing); - } - else { - die "Can't iterate with a $ref"; - } -} - -=head3 C<make_stream_iterator> - -Make a new stream iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Stream>. - -=head3 C<make_array_iterator> - -Make a new array iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Array>. - -=head3 C<make_process_iterator> - -Make a new process iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Process>. - -=cut - -sub make_stream_iterator { - my $proto = shift; - TAP::Parser::Iterator::Stream->new(@_); -} - -sub make_array_iterator { - my $proto = shift; - TAP::Parser::Iterator::Array->new(@_); -} - -sub make_process_iterator { - my $proto = shift; - TAP::Parser::Iterator::Process->new(@_); -} - -1; - -=head1 SUBCLASSING - -Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. - -There are a few things to bear in mind when creating your own -C<ResultFactory>: - -=over 4 - -=item 1 - -The factory itself is never instantiated (this I<may> change in the future). -This means that C<_initialize> is never called. - -=back - -=head2 Example - - package MyIteratorFactory; - - use strict; - use vars '@ISA'; - - use MyStreamIterator; - use TAP::Parser::IteratorFactory; - - @ISA = qw( TAP::Parser::IteratorFactory ); - - # override stream iterator - sub make_stream_iterator { - my $proto = shift; - MyStreamIterator->new(@_); - } - - 1; - -=head1 ATTRIBUTION - -Originally ripped off from L<Test::Harness>. - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Iterator>, -L<TAP::Parser::Iterator::Array>, -L<TAP::Parser::Iterator::Stream>, -L<TAP::Parser::Iterator::Process>, - -=cut - diff --git a/ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm deleted file mode 100644 index 2e5d929688..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm +++ /dev/null @@ -1,195 +0,0 @@ -package TAP::Parser::Multiplexer; - -use strict; -use vars qw($VERSION @ISA); - -use IO::Select; -use TAP::Object (); - -use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/; -use constant IS_VMS => $^O eq 'VMS'; -use constant SELECT_OK => !( IS_VMS || IS_WIN32 ); - -@ISA = 'TAP::Object'; - -=head1 NAME - -TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=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<TAP::Parser::Multiplexer> 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<TAP::Harness> for an example of its use. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $mux = TAP::Parser::Multiplexer->new; - -Returns a new C<TAP::Parser::Multiplexer> 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<add> - - $mux->add( $parser, $stash ); - -Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque -reference that will be returned from C<next> 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<parsers> - - my $count = $mux->parsers; - -Returns the number of parsers. Parsers are removed from the multiplexer -when their input is exhausted. - -=cut - -sub parsers { - my $self = shift; - return $self->{count} + scalar @{ $self->{avid} }; -} - -sub _iter { - my $self = shift; - - my $sel = $self->{select}; - my $avid = $self->{avid}; - my @ready = (); - - return sub { - - # Drain all the non-selectable parsers first - if (@$avid) { - my ( $parser, $stash ) = @{ $avid->[0] }; - my $result = $parser->next; - shift @$avid unless defined $result; - return ( $parser, $stash, $result ); - } - - unless (@ready) { - return unless $sel->count; - @ready = $sel->can_read; - } - - my ( $h, $parser, $stash, @handles ) = @{ shift @ready }; - my $result = $parser->next; - - unless ( defined $result ) { - $sel->remove(@handles); - $self->{count}--; - - # Force another can_read - we may now have removed a handle - # thought to have been ready. - @ready = (); - } - - return ( $parser, $stash, $result ); - }; -} - -=head3 C<next> - -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<TAP::Parser> - -L<TAP::Harness> - -=cut - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result.pm b/ext/Test-Harness/lib/TAP/Parser/Result.pm deleted file mode 100644 index b01e95c5d9..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result.pm +++ /dev/null @@ -1,300 +0,0 @@ -package TAP::Parser::Result; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); - -@ISA = '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.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - # abstract class - not meany 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<TAP::Parser> to store objects that -represent the current bit of test output data from TAP (usually a single -line). Unless you're subclassing, you probably won't need to use this module -directly. - -=head2 METHODS - -=head3 C<new> - - # see TAP::Parser::ResultFactory for preferred usage - - # to use directly: - my $result = TAP::Parser::Result->new($token); - -Returns an instance the appropriate class for the test token passed in. - -=cut - -# 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<is_plan> - -Indicates whether or not this is the test plan line. - - 1..3 - -=item * C<is_pragma> - -Indicates whether or not this is a pragma line. - - pragma +strict - -=item * C<is_test> - -Indicates whether or not this is a test line. - - ok 1 Is OK! - -=item * C<is_comment> - -Indicates whether or not this is a comment. - - # this is a comment - -=item * C<is_bailout> - -Indicates whether or not this is bailout line. - - Bail out! We're out of dilithium crystals. - -=item * C<is_version> - -Indicates whether or not this is a TAP version line. - - TAP version 4 - -=item * C<is_unknown> - -Indicates whether or not the current line could be parsed. - - ... this line is junk ... - -=item * C<is_yaml> - -Indicates whether or not this is a YAML chunk. - -=back - -=cut - -############################################################################## - -=head3 C<raw> - - print $result->raw; - -Returns the original line of text which was parsed. - -=cut - -sub raw { shift->{raw} } - -############################################################################## - -=head3 C<type> - - my $type = $result->type; - -Returns the "type" of a token, such as C<comment> or C<test>. - -=cut - -sub type { shift->{type} } - -############################################################################## - -=head3 C<as_string> - - 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<raw> method. - -=cut - -sub as_string { shift->{raw} } - -############################################################################## - -=head3 C<is_ok> - - if ( $result->is_ok ) { ... } - -Reports whether or not a given result has passed. Anything which is B<not> a -test result returns true. This is merely provided as a convenient shortcut. - -=cut - -sub is_ok {1} - -############################################################################## - -=head3 C<passed> - -Deprecated. Please use C<is_ok> instead. - -=cut - -sub passed { - warn 'passed() is deprecated. Please use "is_ok()"'; - shift->is_ok; -} - -############################################################################## - -=head3 C<has_directive> - - 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<has_todo> - - 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<has_skip> - - 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_directive> - -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<TAP::Parser/SUBCLASSING> for a subclassing overview. - -Remember: if you want your subclass to be automatically used by the parser, -you'll have to register it with L<TAP::Parser::ResultFactory/register_type>. - -If you're creating a completely new result I<type>, you'll probably need to -subclass L<TAP::Parser::Grammar> too, or else it'll never get used. - -=head2 Example - - package MyResult; - - use strict; - use vars '@ISA'; - - @ISA = 'TAP::Parser::Result'; - - # register with the factory: - TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); - - sub as_string { 'My results all look the same' } - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::ResultFactory>, -L<TAP::Parser::Result::Bailout>, -L<TAP::Parser::Result::Comment>, -L<TAP::Parser::Result::Plan>, -L<TAP::Parser::Result::Pragma>, -L<TAP::Parser::Result::Test>, -L<TAP::Parser::Result::Unknown>, -L<TAP::Parser::Result::Version>, -L<TAP::Parser::Result::YAML>, - -=cut diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm deleted file mode 100644 index 3e42f4110f..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm +++ /dev/null @@ -1,63 +0,0 @@ -package TAP::Parser::Result::Bailout; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -=head1 NAME - -TAP::Parser::Result::Bailout - Bailout result token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<as_string> - -=back - -=cut - -############################################################################## - -=head2 Instance Methods - -=head3 C<explanation> - - 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; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm deleted file mode 100644 index 1e9ba13c5f..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm +++ /dev/null @@ -1,61 +0,0 @@ -package TAP::Parser::Result::Comment; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -=head1 NAME - -TAP::Parser::Result::Comment - Comment result token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<as_string> - -Note that this method merely returns the comment preceded by a '# '. - -=back - -=cut - -############################################################################## - -=head2 Instance Methods - -=head3 C<comment> - - 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; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm deleted file mode 100644 index 67c01df200..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm +++ /dev/null @@ -1,120 +0,0 @@ -package TAP::Parser::Result::Plan; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -=head1 NAME - -TAP::Parser::Result::Plan - Plan result token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<as_string> - -=item * C<raw> - -=back - -=cut - -############################################################################## - -=head2 Instance Methods - -=head3 C<plan> - - if ( $result->is_plan ) { - print $result->plan; - } - -This is merely a synonym for C<as_string>. - -=cut - -sub plan { '1..' . shift->{tests_planned} } - -############################################################################## - -=head3 C<tests_planned> - - 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<directive> - - 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<has_skip> - - if ( $result->has_skip ) { ... } - -Returns a boolean value indicating whether or not this test has a SKIP -directive. - -=head3 C<explanation> - - 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<todo_list> - - my $todo = $result->todo_list; - for ( @$todo ) { - ... - } - -=cut - -sub todo_list { shift->{todo_list} } - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm deleted file mode 100644 index 3eb62b3322..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm +++ /dev/null @@ -1,63 +0,0 @@ -package TAP::Parser::Result::Pragma; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -=head1 NAME - -TAP::Parser::Result::Pragma - TAP pragma token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<as_string> - -=item * C<raw> - -=back - -=cut - -############################################################################## - -=head2 Instance Methods - -=head3 C<pragmas> - -if ( $result->is_pragma ) { - @pragmas = $result->pragmas; -} - -=cut - -sub pragmas { - my @pragmas = @{ shift->{pragmas} }; - return wantarray ? @pragmas : \@pragmas; -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Test.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Test.pm deleted file mode 100644 index 11cf302de6..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Test.pm +++ /dev/null @@ -1,274 +0,0 @@ -package TAP::Parser::Result::Test; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -use vars qw($VERSION); - -=head1 NAME - -TAP::Parser::Result::Test - Test result token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<TAP::Parser> 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<ok> - - my $ok = $result->ok; - -Returns the literal text of the C<ok> or C<not ok> status. - -=cut - -sub ok { shift->{ok} } - -############################################################################## - -=head3 C<number> - - 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<description> - - 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<directive> - - my $directive = $result->directive; - -Returns either C<TODO> or C<SKIP> if either directive was present for a test -line. - -=cut - -sub directive { shift->{directive} } - -############################################################################## - -=head3 C<explanation> - - my $explanation = $result->explanation; - -If a test had either a C<TODO> or C<SKIP> directive, this method will return -the accompanying explantion, if present. - - not ok 17 - 'Pigs can fly' # TODO not enough acid - -For the above line, the explanation is I<not enough acid>. - -=cut - -sub explanation { shift->{explanation} } - -############################################################################## - -=head3 C<is_ok> - - 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<is_unplanned>. - -=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<is_actual_ok> - - 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<actual_passed> - -Deprecated. Please use C<is_actual_ok> instead. - -=cut - -sub actual_passed { - warn 'actual_passed() is deprecated. Please use "is_actual_ok()"'; - goto &is_actual_ok; -} - -############################################################################## - -=head3 C<todo_passed> - - 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<todo_failed> - - # 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<todo_passed>. - -=cut - -sub todo_failed { - warn 'todo_failed() is deprecated. Please use "todo_passed()"'; - goto &todo_passed; -} - -############################################################################## - -=head3 C<has_skip> - - if ( $result->has_skip ) { ... } - -Returns a boolean value indicating whether or not this test has a SKIP -directive. - -=head3 C<has_todo> - - if ( $result->has_todo ) { ... } - -Returns a boolean value indicating whether or not this test has a TODO -directive. - -=head3 C<as_string> - - 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<raw> 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<is_unplanned> - - 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<always> return false for C<is_ok>, -regardless of whether or not the test C<has_todo>. - -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; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm deleted file mode 100644 index 52e19585d9..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm +++ /dev/null @@ -1,51 +0,0 @@ -package TAP::Parser::Result::Unknown; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -use vars qw($VERSION); - -=head1 NAME - -TAP::Parser::Result::Unknown - Unknown result token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<as_string> - -=item * C<raw> - -=back - -=cut - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Version.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Version.pm deleted file mode 100644 index b97681eb06..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Version.pm +++ /dev/null @@ -1,63 +0,0 @@ -package TAP::Parser::Result::Version; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -=head1 NAME - -TAP::Parser::Result::Version - TAP syntax version token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<as_string> - -=item * C<raw> - -=back - -=cut - -############################################################################## - -=head2 Instance Methods - -=head3 C<version> - - if ( $result->is_version ) { - print $result->version; - } - -This is merely a synonym for C<as_string>. - -=cut - -sub version { shift->{version} } - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm deleted file mode 100644 index ada3ae445b..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm +++ /dev/null @@ -1,62 +0,0 @@ -package TAP::Parser::Result::YAML; - -use strict; - -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -=head1 NAME - -TAP::Parser::Result::YAML - YAML result token. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 DESCRIPTION - -This is a subclass of L<TAP::Parser::Result>. 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<as_string> - -=item * C<raw> - -=back - -=cut - -############################################################################## - -=head2 Instance Methods - -=head3 C<data> - - if ( $result->is_yaml ) { - print $result->data; - } - -Return the parsed YAML data for this result - -=cut - -sub data { shift->{data} } - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm deleted file mode 100644 index 46d0df29db..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm +++ /dev/null @@ -1,189 +0,0 @@ -package TAP::Parser::ResultFactory; - -use strict; -use vars qw($VERSION @ISA %CLASS_FOR); - -use TAP::Object (); -use TAP::Parser::Result::Bailout (); -use TAP::Parser::Result::Comment (); -use TAP::Parser::Result::Plan (); -use TAP::Parser::Result::Pragma (); -use TAP::Parser::Result::Test (); -use TAP::Parser::Result::Unknown (); -use TAP::Parser::Result::Version (); -use TAP::Parser::Result::YAML (); - -@ISA = 'TAP::Object'; - -############################################################################## - -=head1 NAME - -TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects - -=head1 SYNOPSIS - - use TAP::Parser::ResultFactory; - my $token = {...}; - my $factory = TAP::Parser::ResultFactory->new; - my $result = $factory->make_result( $token ); - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head2 DESCRIPTION - -This is a simple factory class which returns a L<TAP::Parser::Result> subclass -representing the current bit of test data from TAP (usually a single line). -It is used primarily by L<TAP::Parser::Grammar>. Unless you're subclassing, -you probably won't need to use this module directly. - -=head2 METHODS - -=head2 Class Methods - -=head3 C<new> - -Creates a new factory class. -I<Note:> You currently don't need to instantiate a factory in order to use it. - -=head3 C<make_result> - -Returns an instance the appropriate class for the test token passed in. - - my $result = TAP::Parser::ResultFactory->make_result($token); - -Can also be called as an instance method. - -=cut - -sub make_result { - my ( $proto, $token ) = @_; - my $type = $token->{type}; - return $proto->class_for($type)->new($token); -} - -=head3 C<class_for> - -Takes one argument: C<$type>. Returns the class for this $type, or C<croak>s -with an error. - -=head3 C<register_type> - -Takes two arguments: C<$type>, C<$class> - -This lets you override an existing type with your own custom type, or register -a completely new type, eg: - - # create a custom result type: - package MyResult; - use strict; - use vars qw(@ISA); - @ISA = 'TAP::Parser::Result'; - - # register with the factory: - TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); - - # use it: - my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } ); - -Your custom type should then be picked up automatically by the L<TAP::Parser>. - -=cut - -BEGIN { - %CLASS_FOR = ( - plan => 'TAP::Parser::Result::Plan', - pragma => 'TAP::Parser::Result::Pragma', - test => 'TAP::Parser::Result::Test', - comment => 'TAP::Parser::Result::Comment', - bailout => 'TAP::Parser::Result::Bailout', - version => 'TAP::Parser::Result::Version', - unknown => 'TAP::Parser::Result::Unknown', - yaml => 'TAP::Parser::Result::YAML', - ); -} - -sub class_for { - my ( $class, $type ) = @_; - - # return target class: - return $CLASS_FOR{$type} if exists $CLASS_FOR{$type}; - - # or complain: - require Carp; - Carp::croak("Could not determine class for result type '$type'"); -} - -sub register_type { - my ( $class, $type, $rclass ) = @_; - - # register it blindly, assume they know what they're doing - $CLASS_FOR{$type} = $rclass; - return $class; -} - -1; - -=head1 SUBCLASSING - -Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. - -There are a few things to bear in mind when creating your own -C<ResultFactory>: - -=over 4 - -=item 1 - -The factory itself is never instantiated (this I<may> change in the future). -This means that C<_initialize> is never called. - -=item 2 - -C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed. -This I<will> change in a future version! - -=item 3 - -L<TAP::Parser::Result> subclasses will register themselves with -L<TAP::Parser::ResultFactory> directly: - - package MyFooResult; - TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ ); - -Of course, it's up to you to decide whether or not to ignore them. - -=back - -=head2 Example - - package MyResultFactory; - - use strict; - use vars '@ISA'; - - use MyResult; - use TAP::Parser::ResultFactory; - - @ISA = qw( TAP::Parser::ResultFactory ); - - # force all results to be 'MyResult' - sub class_for { - return 'MyResult'; - } - - 1; - -=head1 SEE ALSO - -L<TAP::Parser>, -L<TAP::Parser::Result>, -L<TAP::Parser::Grammar> - -=cut diff --git a/ext/Test-Harness/lib/TAP/Parser/Scheduler.pm b/ext/Test-Harness/lib/TAP/Parser/Scheduler.pm deleted file mode 100644 index f1817093af..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Scheduler.pm +++ /dev/null @@ -1,312 +0,0 @@ -package TAP::Parser::Scheduler; - -use strict; -use vars qw($VERSION); -use Carp; -use TAP::Parser::Scheduler::Job; -use TAP::Parser::Scheduler::Spinner; - -=head1 NAME - -TAP::Parser::Scheduler - Schedule tests during parallel testing - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Scheduler; - -=head1 DESCRIPTION - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $sched = TAP::Parser::Scheduler->new; - -Returns a new C<TAP::Parser::Scheduler> object. - -=cut - -sub new { - my $class = shift; - - croak "Need a number of key, value pairs" if @_ % 2; - - my %args = @_; - my $tests = delete $args{tests} || croak "Need a 'tests' argument"; - my $rules = delete $args{rules} || { par => '**' }; - - croak "Unknown arg(s): ", join ', ', sort keys %args - if keys %args; - - # Turn any simple names into a name, description pair. TODO: Maybe - # construct jobs here? - my $self = bless {}, $class; - - $self->_set_rules( $rules, $tests ); - - return $self; -} - -# Build the scheduler data structure. -# -# SCHEDULER-DATA ::= JOB -# || ARRAY OF ARRAY OF SCHEDULER-DATA -# -# The nested arrays are the key to scheduling. The outer array contains -# a list of things that may be executed in parallel. Whenever an -# eligible job is sought any element of the outer array that is ready to -# execute can be selected. The inner arrays represent sequential -# execution. They can only proceed when the first job is ready to run. - -sub _set_rules { - my ( $self, $rules, $tests ) = @_; - my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) } - map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests; - my $schedule = $self->_rule_clause( $rules, \@tests ); - - # If any tests are left add them as a sequential block at the end of - # the run. - $schedule = [ [ $schedule, @tests ] ] if @tests; - - $self->{schedule} = $schedule; -} - -sub _rule_clause { - my ( $self, $rule, $tests ) = @_; - croak 'Rule clause must be a hash' - unless 'HASH' eq ref $rule; - - my @type = keys %$rule; - croak 'Rule clause must have exactly one key' - unless @type == 1; - - my %handlers = ( - par => sub { - [ map { [$_] } @_ ]; - }, - seq => sub { [ [@_] ] }, - ); - - my $handler = $handlers{ $type[0] } - || croak 'Unknown scheduler type: ', $type[0]; - my $val = $rule->{ $type[0] }; - - return $handler->( - map { - 'HASH' eq ref $_ - ? $self->_rule_clause( $_, $tests ) - : $self->_expand( $_, $tests ) - } 'ARRAY' eq ref $val ? @$val : $val - ); -} - -sub _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; -} - -=head3 C<get_all> - -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<get_job> - -Return the next available job or C<undef> if none are available. Returns -a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending -jobs but none are available to run right now. - -=cut - -sub get_job { - my $self = shift; - $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; - foreach (@$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<as_string> - -Return a human readable representation of the scheduling tree. - -=cut - -sub as_string { - my $self = shift; - return $self->_as_string( $self->{schedule} ); -} - -sub _as_string { - my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 ); - my $pad = ' ' x 2; - my $indent = $pad x $depth; - if ( !defined $rule ) { - return "$indent(undef)\n"; - } - elsif ( 'ARRAY' eq ref $rule ) { - return unless @$rule; - my $type = ( 'par', 'seq' )[ $depth % 2 ]; - return join( - '', "$indent$type:\n", - map { $self->_as_string( $_, $depth + 1 ) } @$rule - ); - } - else { - return "$indent'" . $rule->filename . "'\n"; - } -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm deleted file mode 100644 index 7ab68f9f67..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm +++ /dev/null @@ -1,107 +0,0 @@ -package TAP::Parser::Scheduler::Job; - -use strict; -use vars qw($VERSION); -use Carp; - -=head1 NAME - -TAP::Parser::Scheduler::Job - A single testing job. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Scheduler::Job; - -=head1 DESCRIPTION - -Represents a single test 'job'. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $job = TAP::Parser::Scheduler::Job->new( - $name, $desc - ); - -Returns a new C<TAP::Parser::Scheduler::Job> object. - -=cut - -sub new { - my ( $class, $name, $desc, @ctx ) = @_; - return bless { - filename => $name, - description => $desc, - @ctx ? ( context => \@ctx ) : (), - }, $class; -} - -=head3 C<on_finish> - -Register a closure to be called when this job is destroyed. - -=cut - -sub on_finish { - my ( $self, $cb ) = @_; - $self->{on_finish} = $cb; -} - -=head3 C<finish> - -Called when a job is complete to unlock it. - -=cut - -sub finish { - my $self = shift; - if ( my $cb = $self->{on_finish} ) { - $cb->($self); - } -} - -=head3 C<filename> - -=head3 C<description> - -=head3 C<context> - -=cut - -sub filename { shift->{filename} } -sub description { shift->{description} } -sub context { @{ shift->{context} || [] } } - -=head3 C<as_array_ref> - -For backwards compatibility in callbacks. - -=cut - -sub as_array_ref { - my $self = shift; - return [ $self->filename, $self->description, $self->{context} ||= [] ]; -} - -=head3 C<is_spinner> - -Returns false indicating that this is a real job rather than a -'spinner'. Spinners are returned when the scheduler still has pending -jobs but can't (because of locking) return one right now. - -=cut - -sub is_spinner {0} - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm deleted file mode 100644 index 10af5e3369..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm +++ /dev/null @@ -1,53 +0,0 @@ -package TAP::Parser::Scheduler::Spinner; - -use strict; -use vars qw($VERSION); -use Carp; - -=head1 NAME - -TAP::Parser::Scheduler::Spinner - A no-op job. - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Scheduler::Spinner; - -=head1 DESCRIPTION - -A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to -the harness to spin (keep executing tests) while the scheduler can't -return a real job. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $job = TAP::Parser::Scheduler::Spinner->new; - -Returns a new C<TAP::Parser::Scheduler::Spinner> object. - -=cut - -sub new { bless {}, shift } - -=head3 C<is_spinner> - -Returns true indicating that is a 'spinner' job. Spinners are returned -when the scheduler still has pending jobs but can't (because of locking) -return one right now. - -=cut - -sub is_spinner {1} - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/Source.pm b/ext/Test-Harness/lib/TAP/Parser/Source.pm deleted file mode 100644 index 9263e9e544..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Source.pm +++ /dev/null @@ -1,173 +0,0 @@ -package TAP::Parser::Source; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); -use TAP::Parser::IteratorFactory (); - -@ISA = qw(TAP::Object); - -# Causes problem on MacOS and shouldn't be necessary anyway -#$SIG{CHLD} = sub { wait }; - -=head1 NAME - -TAP::Parser::Source - Stream output from some source - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Source; - my $source = TAP::Parser::Source->new; - my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream; - -=head1 DESCRIPTION - -Takes a command and hopefully returns a stream from it. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $source = TAP::Parser::Source->new; - -Returns a new C<TAP::Parser::Source> object. - -=cut - -# new() implementation supplied by TAP::Object - -sub _initialize { - my ( $self, $args ) = @_; - $self->{switches} = []; - _autoflush( \*STDOUT ); - _autoflush( \*STDERR ); - return $self; -} - -############################################################################## - -=head2 Instance Methods - -=head3 C<source> - - my $source = $source->source; - $source->source(['./some_prog some_test_file']); - - # or - $source->source(['/usr/bin/ruby', 't/ruby_test.rb']); - -Getter/setter for the source. The source should generally consist of an array -reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>, -should return a filehandle which returns successive rows of TAP. C<croaks> if -it doesn't get an arrayref. - -=cut - -sub source { - my $self = shift; - return $self->{source} unless @_; - unless ( 'ARRAY' eq ref $_[0] ) { - $self->_croak('Argument to &source must be an array reference'); - } - $self->{source} = shift; - return $self; -} - -############################################################################## - -=head3 C<get_stream> - - my $stream = $source->get_stream; - -Returns a L<TAP::Parser::Iterator> stream of the output generated by executing -C<source>. C<croak>s if there was no command found. - -Must be passed an object that implements a C<make_iterator> method. -Typically this is a TAP::Parser instance. - -=cut - -sub get_stream { - my ( $self, $factory ) = @_; - my @command = $self->_get_command - or $self->_croak('No command found!'); - - return $factory->make_iterator( - { command => \@command, - merge => $self->merge - } - ); -} - -sub _get_command { return @{ shift->source || [] } } - -############################################################################## - -=head3 C<merge> - - my $merge = $source->merge; - -Sets or returns the flag that dictates whether STDOUT and STDERR are merged. - -=cut - -sub merge { - my $self = shift; - return $self->{merge} unless @_; - $self->{merge} = shift; - return $self; -} - -# Turns on autoflush for the handle passed -sub _autoflush { - my $flushed = shift; - my $old_fh = select $flushed; - $| = 1; - select $old_fh; -} - -1; - -=head1 SUBCLASSING - -Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. - -=head2 Example - - package MyRubySource; - - use strict; - use vars '@ISA'; - - use Carp qw( croak ); - use TAP::Parser::Source; - - @ISA = qw( TAP::Parser::Source ); - - # expect $source->(['mytest.rb', 'cmdline', 'args']); - sub source { - my ($self, $args) = @_; - my ($rb_file) = @$args; - croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file); - return $self->SUPER::source(['/usr/bin/ruby', @$args]); - } - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Source::Perl>, - -=cut - diff --git a/ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm b/ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm deleted file mode 100644 index 1f4f2e1428..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm +++ /dev/null @@ -1,326 +0,0 @@ -package TAP::Parser::Source::Perl; - -use strict; -use Config; -use vars qw($VERSION @ISA); - -use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); -use constant IS_VMS => ( $^O eq 'VMS' ); - -use TAP::Parser::Source; -use TAP::Parser::Utils qw( split_shell ); - -@ISA = 'TAP::Parser::Source'; - -=head1 NAME - -TAP::Parser::Source::Perl - Stream Perl output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Source::Perl; - my $perl = TAP::Parser::Source::Perl->new; - my $stream = $perl->source( [ $filename, @args ] )->get_stream; - -=head1 DESCRIPTION - -Takes a filename and hopefully returns a stream from it. The filename should -be the name of a Perl program. - -Note that this is a subclass of L<TAP::Parser::Source>. See that module for -more methods. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $perl = TAP::Parser::Source::Perl->new; - -Returns a new C<TAP::Parser::Source::Perl> object. - -=head2 Instance Methods - -=head3 C<source> - -Getter/setter the name of the test program and any arguments it requires. - - my ($filename, @args) = @{ $perl->source }; - $perl->source( [ $filename, @args ] ); - -C<croak>s if C<$filename> could not be found. - -=cut - -sub source { - my $self = shift; - $self->_croak("Cannot find ($_[0][0])") - if @_ && !-f $_[0][0]; - return $self->SUPER::source(@_); -} - -=head3 C<switches> - - my $switches = $perl->switches; - my @switches = $perl->switches; - $perl->switches( \@switches ); - -Getter/setter for the additional switches to pass to the perl executable. One -common switch would be to set an include directory: - - $perl->switches( ['-Ilib'] ); - -=cut - -sub switches { - my $self = shift; - unless (@_) { - return wantarray ? @{ $self->{switches} } : $self->{switches}; - } - my $switches = shift; - $self->{switches} = [@$switches]; # force a copy - return $self; -} - -############################################################################## - -=head3 C<get_stream> - - my $stream = $source->get_stream($parser); - -Returns a stream of the output generated by executing C<source>. Must be -passed an object that implements a C<make_iterator> method. Typically -this is a TAP::Parser instance. - -=cut - -sub get_stream { - my ( $self, $factory ) = @_; - - my @switches = $self->_switches; - my $path_sep = $Config{path_sep}; - my $path_pat = qr{$path_sep}; - - # Filter out any -I switches to be handled as libs later. - # - # Nasty kludge. It might be nicer if we got the libs separately - # although at least this way we find any -I switches that were - # supplied other then as explicit libs. - # - # We filter out any names containing colons because they will break - # PERL5LIB - my @libs; - my @filtered_switches; - for (@switches) { - if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { - push @libs, $1; - } - else { - push @filtered_switches, $_; - } - } - @switches = @filtered_switches; - - my $setup = sub { - if (@libs) { - $ENV{PERL5LIB} - = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); - } - }; - - # Cargo culted from comments seen elsewhere about VMS / environment - # variables. I don't know if this is actually necessary. - my $previous = $ENV{PERL5LIB}; - my $teardown = sub { - if ( defined $previous ) { - $ENV{PERL5LIB} = $previous; - } - else { - delete $ENV{PERL5LIB}; - } - }; - - # Taint mode ignores environment variables so we must retranslate - # PERL5LIB as -I switches and place PERL5OPT on the command line - # in order that it be seen. - if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { - push @switches, $self->_libs2switches(@libs); - push @switches, split_shell( $ENV{PERL5OPT} ); - } - - my @command = $self->_get_command_for_switches(@switches) - or $self->_croak("No command found!"); - - return $factory->make_iterator( - { command => \@command, - merge => $self->merge, - setup => $setup, - teardown => $teardown, - } - ); -} - -sub _get_command_for_switches { - my $self = shift; - my @switches = @_; - my ( $file, @args ) = @{ $self->source }; - my $command = $self->_get_perl; - -# XXX we never need to quote if we treat the parts as atoms (except maybe vms) -#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); - my @command = ( $command, @switches, $file, @args ); - return @command; -} - -sub _get_command { - my $self = shift; - return $self->_get_command_for_switches( $self->_switches ); -} - -sub _libs2switches { - my $self = shift; - return map {"-I$_"} grep {$_} @_; -} - -=head3 C<shebang> - -Get the shebang line for a script file. - - my $shebang = TAP::Parser::Source::Perl->shebang( $some_script ); - -May be called as a class method - -=cut - -{ - - # Global shebang cache. - my %shebang_for; - - sub _read_shebang { - my $file = shift; - local *TEST; - my $shebang; - if ( open( TEST, $file ) ) { - $shebang = <TEST>; - close(TEST) or print "Can't close $file. $!\n"; - } - else { - print "Can't open $file. $!\n"; - } - return $shebang; - } - - sub shebang { - my ( $class, $file ) = @_; - unless ( exists $shebang_for{$file} ) { - $shebang_for{$file} = _read_shebang($file); - } - return $shebang_for{$file}; - } -} - -=head3 C<get_taint> - -Decode any taint switches from a Perl shebang line. - - # $taint will be 't' - my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' ); - - # $untaint will be undefined - my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' ); - -=cut - -sub get_taint { - my ( $class, $shebang ) = @_; - return - unless defined $shebang - && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; - return $1; -} - -sub _switches { - my $self = shift; - my ( $file, @args ) = @{ $self->source }; - my @switches = ( - $self->switches, - ); - - my $shebang = $self->shebang($file); - return unless defined $shebang; - - my $taint = $self->get_taint($shebang); - push @switches, "-$taint" if defined $taint; - - # Quote the argument if we're VMS, since VMS will downcase anything - # not quoted. - if (IS_VMS) { - for (@switches) { - $_ = qq["$_"]; - } - } - - return @switches; -} - -sub _get_perl { - my $self = shift; - return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; - return Win32::GetShortPathName($^X) if IS_WIN32; - return $^X; -} - -1; - -=head1 SUBCLASSING - -Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. - -=head2 Example - - package MyPerlSource; - - use strict; - use vars '@ISA'; - - use Carp qw( croak ); - use TAP::Parser::Source::Perl; - - @ISA = qw( TAP::Parser::Source::Perl ); - - sub source { - my ($self, $args) = @_; - if ($args) { - $self->{file} = $args->[0]; - return $self->SUPER::source($args); - } - return $self->SUPER::source; - } - - # use the version of perl from the shebang line in the test file - sub _get_perl { - my $self = shift; - if (my $shebang = $self->shebang( $self->{file} )) { - $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; - return $1 if $1; - } - return $self->SUPER::_get_perl(@_); - } - -=head1 SEE ALSO - -L<TAP::Object>, -L<TAP::Parser>, -L<TAP::Parser::Source>, - -=cut diff --git a/ext/Test-Harness/lib/TAP/Parser/Utils.pm b/ext/Test-Harness/lib/TAP/Parser/Utils.pm deleted file mode 100644 index a3d2dd1ea9..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/Utils.pm +++ /dev/null @@ -1,72 +0,0 @@ -package TAP::Parser::Utils; - -use strict; -use Exporter; -use vars qw($VERSION @ISA @EXPORT_OK); - -@ISA = qw( Exporter ); -@EXPORT_OK = qw( split_shell ); - -=head1 NAME - -TAP::Parser::Utils - Internal TAP::Parser utilities - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Utils qw( split_shell ) - my @switches = split_shell( $arg ); - -=head1 DESCRIPTION - -B<FOR INTERNAL USE ONLY!> - -=head2 INTERFACE - -=head3 C<split_shell> - -Shell style argument parsing. Handles backslash escaping, single and -double quoted strings but not shell substitutions. - -Pass one or more strings containing shell escaped arguments. The return -value is an array of arguments parsed from the input strings according -to (approximate) shell parsing rules. It's legal to pass C<undef> in -which case an empty array will be returned. That makes it possible to - - my @args = split_shell( $ENV{SOME_ENV_VAR} ); - -without worrying about whether the environment variable exists. - -This is used to split HARNESS_PERL_ARGS into individual switches. - -=cut - -sub split_shell { - my @parts = (); - - for my $switch ( grep defined && length, @_ ) { - push @parts, $1 while $switch =~ / - ( - (?: [^\\"'\s]+ - | \\. - | " (?: \\. | [^"] )* " - | ' (?: \\. | [^'] )* ' - )+ - ) /xg; - } - - for (@parts) { - s/ \\(.) | ['"] /defined $1 ? $1 : ''/exg; - } - - return @parts; -} - -1; diff --git a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm deleted file mode 100644 index 524d7dca8d..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm +++ /dev/null @@ -1,333 +0,0 @@ -package TAP::Parser::YAMLish::Reader; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); - -@ISA = 'TAP::Object'; -$VERSION = '3.17'; - -# TODO: -# Handle blessed object syntax - -# Printable characters for escapes -my %UNESCAPES = ( - z => "\x00", a => "\x07", t => "\x09", - n => "\x0a", v => "\x0b", f => "\x0c", - r => "\x0d", e => "\x1b", '\\' => '\\', -); - -my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x; -my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x; -my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x; -my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x; -my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x; - -# new() implementation supplied by TAP::Object - -sub read { - my $self = shift; - my $obj = shift; - - die "Must have a code reference to read input from" - unless ref $obj eq 'CODE'; - - $self->{reader} = $obj; - $self->{capture} = []; - - #Â Prime the reader - $self->_next; - return unless $self->{next}; - - my $doc = $self->_read; - - # The terminator is mandatory otherwise we'd consume a line from the - # iterator that doesn't belong to us. If we want to remove this - # restriction we'll have to implement look-ahead in the iterators. - # Which might not be a bad idea. - my $dots = $self->_peek; - die "Missing '...' at end of YAMLish" - unless defined $dots - and $dots =~ $IS_END_YAML; - - delete $self->{reader}; - delete $self->{next}; - - return $doc; -} - -sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" } - -sub _peek { - my $self = shift; - return $self->{next} unless wantarray; - my $line = $self->{next}; - $line =~ /^ (\s*) (.*) $ /x; - return ( $2, length $1 ); -} - -sub _next { - my $self = shift; - die "_next called with no reader" - unless $self->{reader}; - my $line = $self->{reader}->(); - $self->{next} = $line; - push @{ $self->{capture} }, $line; -} - -sub _read { - my $self = shift; - - my $line = $self->_peek; - - # Do we have a document header? - if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) { - $self->_next; - - return $self->_read_scalar($1) if defined $1; # Inline? - - my ( $next, $indent ) = $self->_peek; - - if ( $next =~ /^ - /x ) { - return $self->_read_array($indent); - } - elsif ( $next =~ $IS_HASH_KEY ) { - return $self->_read_hash( $next, $indent ); - } - elsif ( $next =~ $IS_END_YAML ) { - die "Premature end of YAMLish"; - } - else { - die "Unsupported YAMLish syntax: '$next'"; - } - } - else { - die "YAMLish document header not found"; - } -} - -# Parse a double quoted string -sub _read_qq { - my $self = shift; - my $str = shift; - - unless ( $str =~ s/^ " (.*?) " $/$1/x ) { - die "Internal: not a quoted string"; - } - - $str =~ s/\\"/"/gx; - $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) - / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex; - return $str; -} - -# Parse a scalar string to the actual scalar -sub _read_scalar { - my $self = shift; - my $string = shift; - - return undef if $string eq '~'; - return {} if $string eq '{}'; - return [] if $string eq '[]'; - - if ( $string eq '>' || $string eq '|' ) { - - my ( $line, $indent ) = $self->_peek; - die "Multi-line scalar content missing" unless defined $line; - - my @multiline = ($line); - - while (1) { - $self->_next; - my ( $next, $ind ) = $self->_peek; - last if $ind < $indent; - - my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : ''; - push @multiline, $pad . $next; - } - - return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n"; - } - - if ( $string =~ /^ ' (.*) ' $/x ) { - ( my $rv = $1 ) =~ s/''/'/g; - return $rv; - } - - if ( $string =~ $IS_QQ_STRING ) { - return $self->_read_qq($string); - } - - if ( $string =~ /^['"]/ ) { - - # A quote with folding... we don't support that - die __PACKAGE__ . " does not support multi-line quoted scalars"; - } - - # Regular unquoted string - return $string; -} - -sub _read_nested { - my $self = shift; - - my ( $line, $indent ) = $self->_peek; - - if ( $line =~ /^ -/x ) { - return $self->_read_array($indent); - } - elsif ( $line =~ $IS_HASH_KEY ) { - return $self->_read_hash( $line, $indent ); - } - else { - die "Unsupported YAMLish syntax: '$line'"; - } -} - -# Parse an array -sub _read_array { - my ( $self, $limit ) = @_; - - my $ar = []; - - while (1) { - my ( $line, $indent ) = $self->_peek; - last - if $indent < $limit - || !defined $line - || $line =~ $IS_END_YAML; - - if ( $indent > $limit ) { - die "Array line over-indented"; - } - - if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) { - $indent += length $1; - $line =~ s/-\s+//; - push @$ar, $self->_read_hash( $line, $indent ); - } - elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) { - die "Unexpected start of YAMLish" if $line =~ /^---/; - $self->_next; - push @$ar, $self->_read_scalar($1); - } - elsif ( $line =~ /^ - \s* $/x ) { - $self->_next; - push @$ar, $self->_read_nested; - } - elsif ( $line =~ $IS_HASH_KEY ) { - $self->_next; - push @$ar, $self->_read_hash( $line, $indent, ); - } - else { - die "Unsupported YAMLish syntax: '$line'"; - } - } - - return $ar; -} - -sub _read_hash { - my ( $self, $line, $limit ) = @_; - - my $indent; - my $hash = {}; - - while (1) { - die "Badly formed hash line: '$line'" - unless $line =~ $HASH_LINE; - - my ( $key, $value ) = ( $self->_read_scalar($1), $2 ); - $self->_next; - - if ( defined $value ) { - $hash->{$key} = $self->_read_scalar($value); - } - else { - $hash->{$key} = $self->_read_nested; - } - - ( $line, $indent ) = $self->_peek; - last - if $indent < $limit - || !defined $line - || $line =~ $IS_END_YAML; - } - - return $hash; -} - -1; - -__END__ - -=pod - -=head1 NAME - -TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator - -=head1 VERSION - -Version 3.17 - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Note that parts of this code were derived from L<YAML::Tiny> with the -permission of Adam Kennedy. - -=head1 METHODS - -=head2 Class Methods - -=head3 C<new> - -The constructor C<new> creates and returns an empty -C<TAP::Parser::YAMLish::Reader> object. - - my $reader = TAP::Parser::YAMLish::Reader->new; - -=head2 Instance Methods - -=head3 C<read> - - my $got = $reader->read($stream); - -Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it -represents. - -=head3 C<get_raw> - - my $source = $reader->get_source; - -Return the raw YAMLish source from the most recent C<read>. - -=head1 AUTHOR - -Andy Armstrong, <andy@hexten.net> - -Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of -the YAML matching regular expressions for this module. - -=head1 SEE ALSO - -L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>, -L<http://use.perl.org/~Alias/journal/29427> - -=head1 COPYRIGHT - -Copyright 2007-2008 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 - diff --git a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm deleted file mode 100644 index ed81f6d819..0000000000 --- a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm +++ /dev/null @@ -1,255 +0,0 @@ -package TAP::Parser::YAMLish::Writer; - -use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); - -@ISA = 'TAP::Object'; -$VERSION = '3.17'; - -my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; -my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; - -my @UNPRINTABLE = qw( - z x01 x02 x03 x04 x05 x06 a - x08 t n v f r x0e x0f - x10 x11 x12 x13 x14 x15 x16 x17 - x18 x19 x1a e x1c x1d x1e x1f -); - -# new() implementation supplied by TAP::Object - -sub write { - my $self = shift; - - die "Need something to write" - unless @_; - - my $obj = shift; - my $out = shift || \*STDOUT; - - die "Need a reference to something I can write to" - unless ref $out; - - $self->{writer} = $self->_make_writer($out); - - $self->_write_obj( '---', $obj ); - $self->_put('...'); - - delete $self->{writer}; -} - -sub _make_writer { - my $self = shift; - my $out = shift; - - my $ref = ref $out; - - if ( 'CODE' eq $ref ) { - return $out; - } - elsif ( 'ARRAY' eq $ref ) { - return sub { push @$out, shift }; - } - elsif ( 'SCALAR' eq $ref ) { - return sub { $$out .= shift() . "\n" }; - } - elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) { - return sub { print $out shift(), "\n" }; - } - - die "Can't write to $out"; -} - -sub _put { - my $self = shift; - $self->{writer}->( join '', @_ ); -} - -sub _enc_scalar { - my $self = shift; - my $val = shift; - my $rule = shift; - - return '~' unless defined $val; - - if ( $val =~ /$rule/ ) { - $val =~ s/\\/\\\\/g; - $val =~ s/"/\\"/g; - $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex; - return qq{"$val"}; - } - - if ( length($val) == 0 or $val =~ /\s/ ) { - $val =~ s/'/''/; - return "'$val'"; - } - - return $val; -} - -sub _write_obj { - my $self = shift; - my $prefix = shift; - my $obj = shift; - my $indent = shift || 0; - - if ( my $ref = ref $obj ) { - my $pad = ' ' x $indent; - if ( 'HASH' eq $ref ) { - if ( keys %$obj ) { - $self->_put($prefix); - for my $key ( sort keys %$obj ) { - my $value = $obj->{$key}; - $self->_write_obj( - $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':', - $value, $indent + 1 - ); - } - } - else { - $self->_put( $prefix, ' {}' ); - } - } - elsif ( 'ARRAY' eq $ref ) { - if (@$obj) { - $self->_put($prefix); - for my $value (@$obj) { - $self->_write_obj( - $pad . '-', $value, - $indent + 1 - ); - } - } - else { - $self->_put( $prefix, ' []' ); - } - } - else { - die "Don't know how to encode $ref"; - } - } - else { - $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) ); - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -TAP::Parser::YAMLish::Writer - Write YAMLish data - -=head1 VERSION - -Version 3.17 - -=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<new> - - my $writer = TAP::Parser::YAMLish::Writer->new; - -The constructor C<new> creates and returns an empty -C<TAP::Parser::YAMLish::Writer> object. - -=head2 Instance Methods - -=head3 C<write> - - $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, <andy@hexten.net> - -=head1 SEE ALSO - -L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>, -L<http://use.perl.org/~Alias/journal/29427> - -=head1 COPYRIGHT - -Copyright 2007-2008 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 - diff --git a/ext/Test-Harness/lib/Test/Harness.pm b/ext/Test-Harness/lib/Test/Harness.pm deleted file mode 100644 index eba3c5efc4..0000000000 --- a/ext/Test-Harness/lib/Test/Harness.pm +++ /dev/null @@ -1,585 +0,0 @@ -package Test::Harness; - -require 5.00405; - -use strict; - -use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); -use constant IS_VMS => ( $^O eq 'VMS' ); - -use TAP::Harness (); -use TAP::Parser::Aggregator (); -use TAP::Parser::Source::Perl (); - -use TAP::Parser::Utils qw( split_shell ); - -use Config; -use Exporter; - -# TODO: Emulate at least some of these -use vars qw( - $VERSION - @ISA @EXPORT @EXPORT_OK - $Verbose $Switches $Debug - $verbose $switches $debug - $Columns - $Color - $Directives - $Timer - $Strap - $has_time_hires - $IgnoreExit -); - -# $ML $Last_ML_Print - -BEGIN { - eval q{use Time::HiRes 'time'}; - $has_time_hires = !$@; -} - -=head1 NAME - -Test::Harness - Run Perl standard test scripts with statistics - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -# 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}; -} - -@ISA = ('Exporter'); -@EXPORT = qw(&runtests); -@EXPORT_OK = qw(&execute_tests $verbose $switches); - -$Verbose = $ENV{HARNESS_VERBOSE} || 0; -$Debug = $ENV{HARNESS_DEBUG} || 0; -$Switches = '-w'; -$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; -$Columns--; # Some shells have trouble with a full line of text. -$Timer = $ENV{HARNESS_TIMER} || 0; -$Color = $ENV{HARNESS_COLOR} || 0; -$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0; - -=head1 SYNOPSIS - - use Test::Harness; - - runtests(@test_files); - -=head1 DESCRIPTION - -Although, for historical reasons, the L<Test::Harness> distribution -takes its name from this module it now exists only to provide -L<TAP::Harness> with an interface that is somewhat backwards compatible -with L<Test::Harness> 2.xx. If you're writing new code consider using -L<TAP::Harness> directly instead. - -Emulation is provided for C<runtests> and C<execute_tests> but the -pluggable 'Straps' interface that previous versions of L<Test::Harness> -supported is not reproduced here. Straps is now available as a stand -alone module: L<Test::Harness::Straps>. - -See L<TAP::Parser>, L<TAP::Harness> 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<die()> with -one of the messages in the DIAGNOSTICS section. - -=cut - -sub _has_taint { - my $test = shift; - return TAP::Parser::Source::Perl->get_taint( - TAP::Parser::Source::Perl->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 seens all the extra junk in @INC -sub _apply_extra_INC { - my $harness = shift; - - $harness->callback( - parser_args => sub { - my ( $args, $test ) = @_; - push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); - } - ); -} - -sub _aggregate_tests { - my ( $harness, $aggregate, @tests ) = @_; - $aggregate->start(); - $harness->aggregate_tests( $aggregate, @tests ); - $aggregate->stop(); - -} - -sub runtests { - my @tests = @_; - - # shield against -l - local ( $\, $, ); - - my $harness = _new_harness(); - my $aggregate = TAP::Parser::Aggregator->new(); - - _aggregate( $harness, $aggregate, @tests ); - - $harness->formatter->summary($aggregate); - - my $total = $aggregate->total; - my $passed = $aggregate->passed; - my $failed = $aggregate->failed; - - my @parsers = $aggregate->parsers; - - my $num_bad = 0; - for my $parser (@parsers) { - $num_bad++ if $parser->has_problems; - } - - die(sprintf( - "Failed %d/%d test programs. %d/%d subtests failed.\n", - $num_bad, scalar @parsers, $failed, $total - ) - ) if $num_bad; - - return $total && $total == $passed; -} - -sub _canon { - my @list = sort { $a <=> $b } @_; - my @ranges = (); - my $count = scalar @list; - my $pos = 0; - - while ( $pos < $count ) { - my $end = $pos + 1; - $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1; - push @ranges, ( $end == $pos + 1 ) - ? $list[$pos] - : join( '-', $list[$pos], $list[ $end - 1 ] ); - $pos = $end; - } - - return join( ' ', @ranges ); -} - -sub _new_harness { - my $sub_args = shift || {}; - - my ( @lib, @switches ); - my @opt = split_shell( $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 => $Directives, - lib => \@lib, - switches => \@switches, - color => $Color, - verbosity => $verbosity, - ignore_exit => $IgnoreExit, - }; - - $args->{stdout} = $sub_args->{out} - if exists $sub_args->{out}; - - 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; - } - else { - die "Unknown HARNESS_OPTIONS item: $opt\n"; - } - } - } - - return TAP::Harness->new($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/[\\\/]+$// foreach @inc; - } - - my @default_inc = _default_inc(); - - my @new_inc; - my %seen; - for my $dir (@inc) { - next if $seen{$dir}++; - - if ( $dir eq ( $default_inc[0] || '' ) ) { - shift @default_inc; - } - else { - push @new_inc, $dir; - } - - shift @default_inc while @default_inc and $seen{ $default_inc[0] }; - } - - return @new_inc; -} - -{ - - # Cache this to avoid repeatedly shelling out to Perl. - my @inc; - - sub _default_inc { - return @inc if @inc; - - local $ENV{PERL5LIB}; - local $ENV{PERLLIB}; - - my $perl = $ENV{HARNESS_PERL} || $^X; - - # Avoid using -l for the benefit of Perl 6 - chomp( @inc = `$perl -e "print join qq[\\n], \@INC, q[]"` ); - return @inc; - } -} - -sub _check_sequence { - my @list = @_; - my $prev; - while ( my $next = shift @list ) { - return if defined $prev && $next <= $prev; - $prev = $next; - } - - return 1; -} - -sub execute_tests { - my %args = @_; - - my $harness = _new_harness( \%args ); - my $aggregate = TAP::Parser::Aggregator->new(); - - my %tot = ( - bonus => 0, - max => 0, - ok => 0, - bad => 0, - good => 0, - files => 0, - tests => 0, - sub_skipped => 0, - todo => 0, - skipped => 0, - bench => undef, - ); - - # Install a callback so we get to see any plans the - #Â harness executes. - $harness->callback( - made_parser => sub { - my $parser = shift; - $parser->callback( - plan => sub { - my $plan = shift; - if ( $plan->directive eq 'SKIP' ) { - $tot{skipped}++; - } - } - ); - } - ); - - _aggregate( $harness, $aggregate, @{ $args{tests} } ); - - $tot{bench} = $aggregate->elapsed; - my @tests = $aggregate->descriptions; - - # TODO: Work out the circumstances under which the files - # and tests totals can differ. - $tot{files} = $tot{tests} = scalar @tests; - - my %failedtests = (); - my %todo_passed = (); - - for my $test (@tests) { - my ($parser) = $aggregate->parsers($test); - - my @failed = $parser->failed; - - my $wstat = $parser->wait; - my $estat = $parser->exit; - my $planned = $parser->tests_planned; - my @errors = $parser->parse_errors; - my $passed = $parser->passed; - my $actual_passed = $parser->actual_passed; - - my $ok_seq = _check_sequence( $parser->actual_passed ); - - # Duplicate exit, wait status semantics of old version - $estat ||= '' unless $wstat; - $wstat ||= ''; - - $tot{max} += ( $planned || 0 ); - $tot{bonus} += $parser->todo_passed; - $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed; - $tot{sub_skipped} += $parser->skipped; - $tot{todo} += $parser->todo; - - if ( @failed || $estat || @errors ) { - $tot{bad}++; - - my $huh_planned = $planned ? undef : '??'; - my $huh_errors = $ok_seq ? undef : '??'; - - $failedtests{$test} = { - 'canon' => $huh_planned - || $huh_errors - || _canon(@failed) - || '??', - 'estat' => $estat, - 'failed' => $huh_planned - || $huh_errors - || scalar @failed, - 'max' => $huh_planned || $planned, - 'name' => $test, - 'wstat' => $wstat - }; - } - else { - $tot{good}++; - } - - my @todo = $parser->todo_passed; - if (@todo) { - $todo_passed{$test} = { - 'canon' => _canon(@todo), - 'estat' => $estat, - 'failed' => scalar @todo, - 'max' => scalar $parser->todo, - 'name' => $test, - 'wstat' => $wstat - }; - } - } - - return ( \%tot, \%failedtests, \%todo_passed ); -} - -=head2 execute_tests( tests => \@test_files, out => \*FH ) - -Runs all the given C<@test_files> (just like C<runtests()>) but -doesn't generate the final report. During testing, progress -information will be written to the currently selected output -filehandle (usually C<STDOUT>), or to the filehandle given by the -C<out> parameter. The I<out> 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<Test::Harness> 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<Test::Harness> sets these before executing the individual tests. - -=over 4 - -=item C<HARNESS_ACTIVE> - -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<HARNESS_VERSION> - -This is the version of C<Test::Harness>. - -=back - -=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS - -=over 4 - -=item C<HARNESS_TIMER> - -Setting this to true will make the harness display the number of -milliseconds each test took. You can also use F<prove>'s C<--timer> -switch. - -=item C<HARNESS_VERBOSE> - -If true, C<Test::Harness> 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<prove> utility. - -=item C<HARNESS_OPTIONS> - -Provide additional options to the harness. Currently supported options are: - -=over - -=item C<< j<n> >> - -Run <n> (default 9) parallel jobs. - -=item C<< f >> - -Use forked parallelism. - -=back - -Multiple options may be separated by colons: - - HARNESS_OPTIONS=j9:f make test - -=back - -=head1 Taint Mode - -Normally when a Perl program is run in taint mode the contents of the -C<PERL5LIB> environment variable do not appear in C<@INC>. - -Because C<PERL5LIB> is often used during testing to add build -directories to C<@INC> C<Test::Harness> (actually -L<TAP::Parser::Source::Perl>) passes the names of any directories found -in C<PERL5LIB> as -I switches. The net effect of this is that -C<PERL5LIB> is honoured even in taint mode. - -=head1 SEE ALSO - -L<TAP::Harness> - -=head1 BUGS - -Please report any bugs or feature requests to -C<bug-test-harness at rt.cpan.org>, or through the web interface at -L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. 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<< <andy@hexten.net> >> - -L<Test::Harness> 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<TEST> 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-2008, Andy Armstrong C<< <andy@hexten.net> >>. 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<perlartistic>. - diff --git a/ext/Test-Harness/t/000-load.t b/ext/Test-Harness/t/000-load.t deleted file mode 100644 index 58d41bfeeb..0000000000 --- a/ext/Test-Harness/t/000-load.t +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -use lib 't/lib'; - -use Test::More tests => 78; - -BEGIN { - - # TAP::Parser must come first - my @classes = qw( - TAP::Parser - App::Prove - App::Prove::State - App::Prove::State::Result - App::Prove::State::Result::Test - TAP::Base - TAP::Formatter::Color - TAP::Formatter::Console::ParallelSession - TAP::Formatter::Console::Session - TAP::Formatter::Console - TAP::Harness - TAP::Parser::Aggregator - TAP::Parser::Grammar - TAP::Parser::Iterator - TAP::Parser::Iterator::Array - TAP::Parser::Iterator::Process - TAP::Parser::Iterator::Stream - TAP::Parser::IteratorFactory - TAP::Parser::Multiplexer - TAP::Parser::Result - TAP::Parser::ResultFactory - TAP::Parser::Result::Bailout - TAP::Parser::Result::Comment - TAP::Parser::Result::Plan - TAP::Parser::Result::Pragma - TAP::Parser::Result::Test - TAP::Parser::Result::Unknown - TAP::Parser::Result::Version - TAP::Parser::Result::YAML - TAP::Parser::Result - TAP::Parser::Scheduler - TAP::Parser::Scheduler::Job - TAP::Parser::Scheduler::Spinner - TAP::Parser::Source::Perl - TAP::Parser::Source - TAP::Parser::YAMLish::Reader - TAP::Parser::YAMLish::Writer - TAP::Parser::Utils - Test::Harness - ); - - foreach my $class (@classes) { - use_ok $class or BAIL_OUT("Could not load $class"); - is $class->VERSION, TAP::Parser->VERSION, - "... and $class should have the correct version"; - } - - diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X") - unless $ENV{PERL_CORE}; -} diff --git a/ext/Test-Harness/t/aggregator.t b/ext/Test-Harness/t/aggregator.t deleted file mode 100644 index c8e32a1c93..0000000000 --- a/ext/Test-Harness/t/aggregator.t +++ /dev/null @@ -1,305 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -use lib 't/lib'; - -use Test::More tests => 81; - -use TAP::Parser; -use TAP::Parser::IteratorFactory; -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 $factory = TAP::Parser::IteratorFactory->new; -my $stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -isa_ok $stream, 'TAP::Parser::Iterator'; - -my $parser1 = TAP::Parser->new( { stream => $stream } ); -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' ) foreach (@$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'; diff --git a/ext/Test-Harness/t/bailout.t b/ext/Test-Harness/t/bailout.t deleted file mode 100644 index e10b133e0f..0000000000 --- a/ext/Test-Harness/t/bailout.t +++ /dev/null @@ -1,114 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -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'; diff --git a/ext/Test-Harness/t/base.t b/ext/Test-Harness/t/base.t deleted file mode 100644 index 4fee54844e..0000000000 --- a/ext/Test-Harness/t/base.t +++ /dev/null @@ -1,173 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -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'; - foreach 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 vars qw(@ISA); -@ISA = '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' ); -} diff --git a/ext/Test-Harness/t/callbacks.t b/ext/Test-Harness/t/callbacks.t deleted file mode 100644 index 18c6f0d15e..0000000000 --- a/ext/Test-Harness/t/callbacks.t +++ /dev/null @@ -1,116 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -use lib 't/lib'; - -use Test::More tests => 10; - -use TAP::Parser; -use TAP::Parser::IteratorFactory; - -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 $factory = TAP::Parser::IteratorFactory->new; -my $stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -my $parser = TAP::Parser->new( - { stream => $stream, - 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++; - }, -); - -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -$parser = TAP::Parser->new( - { stream => $stream, - 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 { }, -); - -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -eval { - $parser = TAP::Parser->new( - { stream => $stream, - callbacks => \%callbacks, - } - ); -}; - -like $@, qr/Callback/, 'Bad callback keys faulted'; diff --git a/ext/Test-Harness/t/compat/env.t b/ext/Test-Harness/t/compat/env.t deleted file mode 100644 index ac5c096213..0000000000 --- a/ext/Test-Harness/t/compat/env.t +++ /dev/null @@ -1,39 +0,0 @@ -#!/usr/bin/perl -w - -# Test that env vars are honoured. - -use strict; -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; diff --git a/ext/Test-Harness/t/compat/failure.t b/ext/Test-Harness/t/compat/failure.t deleted file mode 100644 index 2f80e57884..0000000000 --- a/ext/Test-Harness/t/compat/failure.t +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use lib 't/lib'; - -use Test::More tests => 5; - -use File::Spec; -use Test::Harness; - -{ - - #todo_skip 'Harness compatibility incomplete', 5; - #local $TODO = 'Harness compatibility incomplete'; - my $died; - - sub prepare_for_death { - $died = 0; - return sub { $died = 1 } - } - - my $curdir = File::Spec->curdir; - my $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' ); - - { - local $SIG{__DIE__} = prepare_for_death(); - eval { _runtests( File::Spec->catfile( $sample_tests, "simple" ) ); }; - ok( !$@, "simple lives" ); - is( $died, 0, "Death never happened" ); - } - - { - local $SIG{__DIE__} = prepare_for_death(); - eval { - _runtests( File::Spec->catfile( $sample_tests, "too_many" ) ); - }; - ok( $@, "error OK" ); - ok( $@ =~ m[Failed 1/1], "too_many dies" ); - is( $died, 1, "Death happened" ); - } -} - -sub _runtests { - my (@tests) = @_; - - local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; - local $ENV{HARNESS_VERBOSE} = 0; - local $ENV{HARNESS_DEBUG} = 0; - local $ENV{HARNESS_TIMER} = 0; - - local $Test::Harness::Verbose = -9; - - runtests(@tests); -} - -# vim:ts=4:sw=4:et:sta diff --git a/ext/Test-Harness/t/compat/inc-propagation.t b/ext/Test-Harness/t/compat/inc-propagation.t deleted file mode 100644 index c0d62b0407..0000000000 --- a/ext/Test-Harness/t/compat/inc-propagation.t +++ /dev/null @@ -1,57 +0,0 @@ -#!/usr/bin/perl -w - -# Test that @INC is propogated from the harness process to the test -# process. - -use strict; -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' ) - : ( 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 => 2; - -is $INC[0], "wibble", 'basic order of @INC preserved' or diag "\@INC: @INC"; -like $ENV{PERL5LIB}, qr{wibble}; - -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; diff --git a/ext/Test-Harness/t/compat/inc_taint.t b/ext/Test-Harness/t/compat/inc_taint.t deleted file mode 100644 index 3bd86b4108..0000000000 --- a/ext/Test-Harness/t/compat/inc_taint.t +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/perl -w - -use lib 't/lib'; - -use strict; - -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' ); -} diff --git a/ext/Test-Harness/t/compat/nonumbers.t b/ext/Test-Harness/t/compat/nonumbers.t deleted file mode 100644 index 144a7599b2..0000000000 --- a/ext/Test-Harness/t/compat/nonumbers.t +++ /dev/null @@ -1,14 +0,0 @@ -if ( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) { - print "1..0 # Skip: t/TEST needs numbers\n"; - exit; -} - -print <<END; -1..6 -ok -ok -ok -ok -ok -ok -END diff --git a/ext/Test-Harness/t/compat/regression.t b/ext/Test-Harness/t/compat/regression.t deleted file mode 100644 index 50a4d516c8..0000000000 --- a/ext/Test-Harness/t/compat/regression.t +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -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'; diff --git a/ext/Test-Harness/t/compat/switches.t b/ext/Test-Harness/t/compat/switches.t deleted file mode 100644 index 42b16c8bd4..0000000000 --- a/ext/Test-Harness/t/compat/switches.t +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -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'; -} - diff --git a/ext/Test-Harness/t/compat/test-harness-compat.t b/ext/Test-Harness/t/compat/test-harness-compat.t deleted file mode 100644 index cae9a54333..0000000000 --- a/ext/Test-Harness/t/compat/test-harness-compat.t +++ /dev/null @@ -1,851 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; - -# use lib 't/lib'; - -use Test::More; -use File::Spec; -use Test::Harness qw(execute_tests); - -# unset this global when self-testing ('testcover' and etc issue) -local $ENV{HARNESS_PERL_SWITCHES}; - -my $TEST_DIR = 't/sample-tests'; - -{ - - # if the harness wants to save the resulting TAP we shouldn't - # do it for our internal calls - local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; - - my $PER_LOOP = 4; - - my $results = { - 'descriptive' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 5, - 'ok' => 5, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - join( - ',', qw( - descriptive die die_head_end die_last_minute duplicates - head_end head_fail inc_taint junk_before_plan lone_not_bug - no_nums no_output schwern sequence_misparse shbang_misparse - simple simple_fail skip skip_nomsg skipall skipall_nomsg - stdout_stderr taint todo_inline - todo_misparse too_many vms_nit - ) - ) => { - 'failed' => { - "$TEST_DIR/die" => { - 'canon' => '??', - 'estat' => 1, - 'failed' => '??', - 'max' => '??', - 'name' => "$TEST_DIR/die", - 'wstat' => '256' - }, - "$TEST_DIR/die_head_end" => { - 'canon' => '??', - 'estat' => 1, - 'failed' => '??', - 'max' => '??', - 'name' => "$TEST_DIR/die_head_end", - 'wstat' => '256' - }, - "$TEST_DIR/die_last_minute" => { - 'canon' => '??', - 'estat' => 1, - 'failed' => 0, - 'max' => 4, - 'name' => "$TEST_DIR/die_last_minute", - 'wstat' => '256' - }, - "$TEST_DIR/duplicates" => { - 'canon' => '??', - 'estat' => '', - 'failed' => '??', - 'max' => 10, - 'name' => "$TEST_DIR/duplicates", - 'wstat' => '' - }, - "$TEST_DIR/head_fail" => { - 'canon' => 2, - 'estat' => '', - 'failed' => 1, - 'max' => 4, - 'name' => "$TEST_DIR/head_fail", - 'wstat' => '' - }, - "$TEST_DIR/inc_taint" => { - 'canon' => 1, - 'estat' => 1, - 'failed' => 1, - 'max' => 1, - 'name' => "$TEST_DIR/inc_taint", - 'wstat' => '256' - }, - "$TEST_DIR/no_nums" => { - 'canon' => 3, - 'estat' => '', - 'failed' => 1, - 'max' => 5, - 'name' => "$TEST_DIR/no_nums", - 'wstat' => '' - }, - "$TEST_DIR/no_output" => { - 'canon' => '??', - 'estat' => '', - 'failed' => '??', - 'max' => '??', - 'name' => "$TEST_DIR/no_output", - 'wstat' => '' - }, - "$TEST_DIR/simple_fail" => { - 'canon' => '2 5', - 'estat' => '', - 'failed' => 2, - 'max' => 5, - 'name' => "$TEST_DIR/simple_fail", - 'wstat' => '' - }, - "$TEST_DIR/todo_misparse" => { - 'canon' => 1, - 'estat' => '', - 'failed' => 1, - 'max' => 1, - 'name' => "$TEST_DIR/todo_misparse", - 'wstat' => '' - }, - "$TEST_DIR/too_many" => { - 'canon' => '4-7', - 'estat' => 4, - 'failed' => 4, - 'max' => 3, - 'name' => "$TEST_DIR/too_many", - 'wstat' => '1024' - }, - "$TEST_DIR/vms_nit" => { - 'canon' => 1, - 'estat' => '', - 'failed' => 1, - 'max' => 2, - 'name' => "$TEST_DIR/vms_nit", - 'wstat' => '' - } - }, - 'todo' => { - "$TEST_DIR/todo_inline" => { - 'canon' => 2, - 'estat' => '', - 'failed' => 1, - 'max' => 2, - 'name' => "$TEST_DIR/todo_inline", - 'wstat' => '' - } - }, - 'totals' => { - 'bad' => 12, - 'bonus' => 1, - 'files' => 27, - 'good' => 15, - 'max' => 76, - 'ok' => 78, - 'skipped' => 2, - 'sub_skipped' => 2, - 'tests' => 27, - 'todo' => 2 - } - }, - 'die' => { - 'failed' => { - "$TEST_DIR/die" => { - 'canon' => '??', - 'estat' => 1, - 'failed' => '??', - 'max' => '??', - 'name' => "$TEST_DIR/die", - 'wstat' => '256' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 0, - 'ok' => 0, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'die_head_end' => { - 'failed' => { - "$TEST_DIR/die_head_end" => { - 'canon' => '??', - 'estat' => 1, - 'failed' => '??', - 'max' => '??', - 'name' => "$TEST_DIR/die_head_end", - 'wstat' => '256' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 0, - 'ok' => 4, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'die_last_minute' => { - 'failed' => { - "$TEST_DIR/die_last_minute" => { - 'canon' => '??', - 'estat' => 1, - 'failed' => 0, - 'max' => 4, - 'name' => "$TEST_DIR/die_last_minute", - 'wstat' => '256' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 4, - 'ok' => 4, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'duplicates' => { - 'failed' => { - "$TEST_DIR/duplicates" => { - 'canon' => '??', - 'estat' => '', - 'failed' => '??', - 'max' => 10, - 'name' => "$TEST_DIR/duplicates", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 10, - 'ok' => 11, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'head_end' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 4, - 'ok' => 4, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'head_fail' => { - 'failed' => { - "$TEST_DIR/head_fail" => { - 'canon' => 2, - 'estat' => '', - 'failed' => 1, - 'max' => 4, - 'name' => "$TEST_DIR/head_fail", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 4, - 'ok' => 3, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'inc_taint' => { - 'failed' => { - "$TEST_DIR/inc_taint" => { - 'canon' => 1, - 'estat' => 1, - 'failed' => 1, - 'max' => 1, - 'name' => "$TEST_DIR/inc_taint", - 'wstat' => '256' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 1, - 'ok' => 0, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'junk_before_plan' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 1, - 'ok' => 1, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'lone_not_bug' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 4, - 'ok' => 4, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'no_nums' => { - 'failed' => { - "$TEST_DIR/no_nums" => { - 'canon' => 3, - 'estat' => '', - 'failed' => 1, - 'max' => 5, - 'name' => "$TEST_DIR/no_nums", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 5, - 'ok' => 4, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'no_output' => { - 'failed' => { - "$TEST_DIR/no_output" => { - 'canon' => '??', - 'estat' => '', - 'failed' => '??', - 'max' => '??', - 'name' => "$TEST_DIR/no_output", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 0, - 'ok' => 0, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'schwern' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 1, - 'ok' => 1, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'sequence_misparse' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 5, - 'ok' => 5, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'shbang_misparse' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 2, - 'ok' => 2, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'simple' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 5, - 'ok' => 5, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'simple_fail' => { - 'failed' => { - "$TEST_DIR/simple_fail" => { - 'canon' => '2 5', - 'estat' => '', - 'failed' => 2, - 'max' => 5, - 'name' => "$TEST_DIR/simple_fail", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 5, - 'ok' => 3, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'skip' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 5, - 'ok' => 5, - 'skipped' => 0, - 'sub_skipped' => 1, - 'tests' => 1, - 'todo' => 0 - } - }, - 'skip_nomsg' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 1, - 'ok' => 1, - 'skipped' => 0, - 'sub_skipped' => 1, - 'tests' => 1, - 'todo' => 0 - } - }, - 'skipall' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 0, - 'ok' => 0, - 'skipped' => 1, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'skipall_nomsg' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 0, - 'ok' => 0, - 'skipped' => 1, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'stdout_stderr' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 4, - 'ok' => 4, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'switches' => { - 'skip_if' => sub { - ( $ENV{PERL5OPT} || '' ) =~ m{(?:^|\s)-[dM]}; - }, - 'failed' => { - "$TEST_DIR/switches" => { - 'canon' => 1, - 'estat' => '', - 'failed' => 1, - 'max' => 1, - 'name' => "$TEST_DIR/switches", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 1, - 'ok' => 0, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'taint' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 1, - 'ok' => 1, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'taint_warn' => { - 'failed' => {}, - 'todo' => {}, - 'totals' => { - 'bad' => 0, - 'bonus' => 0, - 'files' => 1, - 'good' => 1, - 'max' => 1, - 'ok' => 1, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - }, - 'require' => 5.008001, - }, - 'todo_inline' => { - 'failed' => {}, - 'todo' => { - "$TEST_DIR/todo_inline" => { - 'canon' => 2, - 'estat' => '', - 'failed' => 1, - 'max' => 2, - 'name' => "$TEST_DIR/todo_inline", - 'wstat' => '' - } - }, - 'totals' => { - 'bad' => 0, - 'bonus' => 1, - 'files' => 1, - 'good' => 1, - 'max' => 3, - 'ok' => 3, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 2 - } - }, - 'todo_misparse' => { - 'failed' => { - "$TEST_DIR/todo_misparse" => { - 'canon' => 1, - 'estat' => '', - 'failed' => 1, - 'max' => 1, - 'name' => "$TEST_DIR/todo_misparse", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 1, - 'ok' => 0, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'too_many' => { - 'failed' => { - "$TEST_DIR/too_many" => { - 'canon' => '4-7', - 'estat' => 4, - 'failed' => 4, - 'max' => 3, - 'name' => "$TEST_DIR/too_many", - 'wstat' => '1024' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 3, - 'ok' => 7, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - }, - 'vms_nit' => { - 'failed' => { - "$TEST_DIR/vms_nit" => { - 'canon' => 1, - 'estat' => '', - 'failed' => 1, - 'max' => 2, - 'name' => "$TEST_DIR/vms_nit", - 'wstat' => '' - } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 2, - 'ok' => 1, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - } - }; - - my $num_tests = ( keys %$results ) * $PER_LOOP; - - plan tests => $num_tests; - - sub local_name { - my $name = shift; - return File::Spec->catfile( split /\//, $name ); - } - - sub local_result { - my $hash = shift; - my $new = {}; - - while ( my ( $file, $want ) = each %$hash ) { - if ( exists $want->{name} ) { - $want->{name} = local_name( $want->{name} ); - } - $new->{ local_name($file) } = $want; - } - return $new; - } - - sub vague_status { - my $hash = shift; - return $hash unless $^O eq 'VMS'; - - while ( my ( $file, $want ) = each %$hash ) { - for (qw( estat wstat )) { - if ( exists $want->{$_} ) { - $want->{$_} = $want->{$_} ? 1 : 0; - } - } - } - return $hash; - } - - { - local $^W = 0; - - # Silence harness output - *TAP::Formatter::Console::_output = sub { - - # do nothing - }; - } - - for my $test_key ( sort keys %$results ) { - my $result = $results->{$test_key}; - SKIP: { - if ( $result->{require} && $] < $result->{require} ) { - skip "Test requires Perl $result->{require}, we have $]", 4; - } - - if ( my $skip_if = $result->{skip_if} ) { - skip - "Test '$test_key' can't run properly in this environment", 4 - if $skip_if->(); - } - - my @test_names = split( /,/, $test_key ); - my @test_files - = map { File::Spec->catfile( $TEST_DIR, $_ ) } @test_names; - - # For now we supress STDERR because it crufts up /our/ test - # results. Should probably capture and analyse it. - local ( *OLDERR, *OLDOUT ); - open OLDERR, '>&STDERR' or die $!; - open OLDOUT, '>&STDOUT' or die $!; - my $devnull = File::Spec->devnull; - open STDERR, ">$devnull" or die $!; - open STDOUT, ">$devnull" or die $!; - - my ( $tot, $fail, $todo, $harness, $aggregate ) - = execute_tests( tests => \@test_files ); - - open STDERR, '>&OLDERR' or die $!; - open STDOUT, '>&OLDOUT' or die $!; - - my $bench = delete $tot->{bench}; - isa_ok $bench, 'Benchmark'; - - # Localise filenames in failed, todo - my $lfailed = vague_status( local_result( $result->{failed} ) ); - my $ltodo = vague_status( local_result( $result->{todo} ) ); - - # use Data::Dumper; - # diag Dumper( [ $lfailed, $ltodo ] ); - - is_deeply $tot, $result->{totals}, "totals match for $test_key"; - is_deeply vague_status($fail), $lfailed, - "failure summary matches for $test_key"; - is_deeply vague_status($todo), $ltodo, - "todo summary matches for $test_key"; - } - } -} diff --git a/ext/Test-Harness/t/compat/version.t b/ext/Test-Harness/t/compat/version.t deleted file mode 100644 index 08344cbd9c..0000000000 --- a/ext/Test-Harness/t/compat/version.t +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/perl -Tw - -use strict; -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 ); diff --git a/ext/Test-Harness/t/console.t b/ext/Test-Harness/t/console.t deleted file mode 100644 index 32f5db62ac..0000000000 --- a/ext/Test-Harness/t/console.t +++ /dev/null @@ -1,47 +0,0 @@ -use strict; -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; diff --git a/ext/Test-Harness/t/data/catme.1 b/ext/Test-Harness/t/data/catme.1 deleted file mode 100644 index 7ecdd9a102..0000000000 --- a/ext/Test-Harness/t/data/catme.1 +++ /dev/null @@ -1,2 +0,0 @@ -1..1 -ok 1 diff --git a/ext/Test-Harness/t/data/proverc b/ext/Test-Harness/t/data/proverc deleted file mode 100644 index 9d2924145d..0000000000 --- a/ext/Test-Harness/t/data/proverc +++ /dev/null @@ -1,7 +0,0 @@ ---should be --split correctly # No comment! -Can "quote things" 'using single or' "double quotes" - -# More stuff ---this -is -'OK?' diff --git a/ext/Test-Harness/t/data/sample.yml b/ext/Test-Harness/t/data/sample.yml deleted file mode 100644 index 6c4b7fbf4a..0000000000 --- a/ext/Test-Harness/t/data/sample.yml +++ /dev/null @@ -1,29 +0,0 @@ ---- -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 - diff --git a/ext/Test-Harness/t/errors.t b/ext/Test-Harness/t/errors.t deleted file mode 100644 index 3a54cbe066..0000000000 --- a/ext/Test-Harness/t/errors.t +++ /dev/null @@ -1,183 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -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'; -} diff --git a/ext/Test-Harness/t/file.t b/ext/Test-Harness/t/file.t deleted file mode 100644 index f97d1aadd0..0000000000 --- a/ext/Test-Harness/t/file.t +++ /dev/null @@ -1,475 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; - -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; - local $^W; - 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; -} - diff --git a/ext/Test-Harness/t/glob-to-regexp.t b/ext/Test-Harness/t/glob-to-regexp.t deleted file mode 100644 index 493daab307..0000000000 --- a/ext/Test-Harness/t/glob-to-regexp.t +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/perl -w - -use strict; - -use Test::More; - -require TAP::Parser::Scheduler; - -my @tests; -while (<DATA>) { - my ( $glob, $pattern, $name ) = /^(\S+)\t+(\S+)(?:\t+(.*))?$/; - die "'$_'" unless $pattern; - push @tests, [ $glob, $pattern, $name ]; -} - -plan tests => scalar @tests; - -foreach (@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 diff --git a/ext/Test-Harness/t/grammar.t b/ext/Test-Harness/t/grammar.t deleted file mode 100644 index b74fc8ba65..0000000000 --- a/ext/Test-Harness/t/grammar.t +++ /dev/null @@ -1,455 +0,0 @@ -#!/usr/bin/perl -w - -use strict; - -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 stream that we can push items in to -package SS; - -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 $stream = SS->new; -my $parser = EmptyParser->new; -can_ok $GRAMMAR, 'new'; -my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); -isa_ok $grammar, $GRAMMAR, '... and the object it returns'; - -# Note: all methods are actually class methods. See the docs for the reason -# 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 ); -foreach 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'; -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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'; - -$stream->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 $stream = SS->new; - my $parser = EmptyParser->new; - my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); - - my $plan = ''; - - $stream->put($plan); - - my $result = $grammar->tokenize(); - - isa_ok $result, 'TAP::Parser::Result::Unknown'; -} - -# _make_plan_token - -{ - my $parser = EmptyParser->new; - my $grammar = $GRAMMAR->new( { parser => $parser } ); - - my $plan - = '1..1 # SKIP with explanation'; # trigger warning in _make_plan_token - - my $method = $handler_for{'plan'}; - - $plan =~ $syntax_for{'plan'}; # perform regex to populate $1, $2 - - my @warn; - - eval { - local $SIG{__WARN__} = sub { push @warn, @_ }; - - $grammar->$method($plan); - }; - - is @warn, 1, 'catch warning on inconsistent plan'; - - like pop @warn, - qr/^Specified SKIP directive in plan but more than 0 tests [(]1\.\.1 # SKIP with explanation[)]/, - '... and its what we expect'; -} - -# _make_yaml_token - -{ - my $stream = SS->new; - my $parser = EmptyParser->new; - my $grammar = $GRAMMAR->new( { stream => $stream, 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->() ) { - $stream->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'; -} diff --git a/ext/Test-Harness/t/harness-bailout.t b/ext/Test-Harness/t/harness-bailout.t deleted file mode 100644 index fd1dc35669..0000000000 --- a/ext/Test-Harness/t/harness-bailout.t +++ /dev/null @@ -1,54 +0,0 @@ -#!perl - -use strict; -use File::Spec; - -BEGIN { - *CORE::GLOBAL::exit = sub { die '!exit called!' }; -} - -use TAP::Harness; -use Test::More; - -my @jobs = ( - { name => 'sequential', - args => { verbosity => -9 }, - }, - { name => 'parallel', - args => { verbosity => -9, jobs => 2 }, - }, -); - -plan tests => @jobs * 2; - -for my $test (@jobs) { - my $name = $test->{name}; - my $args = $test->{args}; - my $harness = TAP::Harness->new($args); - eval { - local ( *OLDERR, *OLDOUT ); - open OLDERR, '>&STDERR' or die $!; - open OLDOUT, '>&STDOUT' or die $!; - my $devnull = File::Spec->devnull; - open STDERR, ">$devnull" or die $!; - open STDOUT, ">$devnull" or die $!; - - $harness->runtests( - File::Spec->catfile( - 't', - 'sample-tests', - 'bailout' - ) - ); - - open STDERR, '>&OLDERR' or die $!; - open STDOUT, '>&OLDOUT' or die $!; - }; - my $err = $@; - unlike $err, qr{!exit called!}, "$name: didn't exit"; - like $err, qr{FAILED--Further testing stopped: GERONIMMMOOOOOO!!!}, - "$name: bailout message"; -} - -# vim:ts=2:sw=2:et:ft=perl - diff --git a/ext/Test-Harness/t/harness-subclass.t b/ext/Test-Harness/t/harness-subclass.t deleted file mode 100644 index c6b46daa21..0000000000 --- a/ext/Test-Harness/t/harness-subclass.t +++ /dev/null @@ -1,65 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; -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'; -} diff --git a/ext/Test-Harness/t/harness.t b/ext/Test-Harness/t/harness.t deleted file mode 100644 index 3643f576f3..0000000000 --- a/ext/Test-Harness/t/harness.t +++ /dev/null @@ -1,982 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; - -use Test::More; -use IO::c55Capture; - -use TAP::Harness; - -my $HARNESS = 'TAP::Harness'; - -my $source_tests = 't/source_tests'; -my $sample_tests = 't/sample-tests'; - -plan tests => 119; - -# 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'; - -foreach my $test_args ( get_arg_sets() ) { - my %args = %$test_args; - foreach 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; - local $^W; - local *TAP::Formatter::Base::_output = sub { - my $self = shift; - push @output => grep { $_ ne '' } - map { - local $_ = $_; - chomp; - trim($_) - } @_; - }; - my $harness = TAP::Harness->new( - { verbosity => 1, formatter_class => "TAP::Formatter::Console" } ); - my $harness_whisper = TAP::Harness->new( - { verbosity => -1, formatter_class => "TAP::Formatter::Console" } ); - my $harness_mute = TAP::Harness->new( - { verbosity => -2, formatter_class => "TAP::Formatter::Console" } ); - my $harness_directives = TAP::Harness->new( - { directives => 1, formatter_class => "TAP::Formatter::Console" } ); - my $harness_failures = TAP::Harness->new( - { failures => 1, formatter_class => "TAP::Formatter::Console" } ); - - colorize($harness); - - can_ok $harness, 'runtests'; - - # normal tests in verbose mode - - ok my $aggregate = _runtests( $harness, "$source_tests/harness" ), - '... runtests returns the aggregate'; - - isa_ok $aggregate, 'TAP::Parser::Aggregator'; - - chomp(@output); - - my @expected = ( - "$source_tests/harness ..", - '1..1', - '[[reset]]', - 'ok 1 - this is a test', - '[[reset]]', - 'ok', - '[[green]]', - 'All tests successful.', - '[[reset]]', - ); - my $status = pop @output; - my $expected_status = qr{^Result: PASS$}; - my $summary = pop @output; - my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; - - is_deeply \@output, \@expected, '... and the output should be correct'; - like $status, $expected_status, - '... and the status line should be correct'; - like $summary, $expected_summary, - '... and the report summary should look correct'; - - # use an alias for test name - - @output = (); - ok $aggregate - = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ), - '... runtests returns the aggregate'; - - isa_ok $aggregate, 'TAP::Parser::Aggregator'; - - chomp(@output); - - @expected = ( - 'My Nice Test ..', - '1..1', - '[[reset]]', - 'ok 1 - this is a test', - '[[reset]]', - 'ok', - '[[green]]', - 'All tests successful.', - '[[reset]]', - ); - $status = pop @output; - $expected_status = qr{^Result: PASS$}; - $summary = pop @output; - $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; - - is_deeply \@output, \@expected, '... and the output should be correct'; - like $status, $expected_status, - '... and the status line should be correct'; - like $summary, $expected_summary, - '... and the report summary should look correct'; - - # run same test twice - - @output = (); - ok $aggregate = _runtests( - $harness, [ "$source_tests/harness", 'My Nice Test' ], - [ "$source_tests/harness", 'My Nice Test Again' ] - ), - '... runtests returns the aggregate'; - - isa_ok $aggregate, 'TAP::Parser::Aggregator'; - - chomp(@output); - - @expected = ( - 'My Nice Test ........', - '1..1', - '[[reset]]', - 'ok 1 - this is a test', - '[[reset]]', - 'ok', - 'My Nice Test Again ..', - '1..1', - '[[reset]]', - 'ok 1 - this is a test', - '[[reset]]', - 'ok', - '[[green]]', - 'All tests successful.', - '[[reset]]', - ); - $status = pop @output; - $expected_status = qr{^Result: PASS$}; - $summary = pop @output; - $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs}; - - is_deeply \@output, \@expected, '... and the output should be correct'; - like $status, $expected_status, - '... and the status line should be correct'; - like $summary, $expected_summary, - '... and the report summary should look correct'; - - # normal tests in quiet mode - - @output = (); - _runtests( $harness_whisper, "$source_tests/harness" ); - - chomp(@output); - @expected = ( - "$source_tests/harness ..", - 'ok', - 'All tests successful.', - ); - - $status = pop @output; - $expected_status = qr{^Result: PASS$}; - $summary = pop @output; - $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; - - is_deeply \@output, \@expected, '... and the output should be correct'; - like $status, $expected_status, - '... and the status line should be correct'; - like $summary, $expected_summary, - '... and the report summary should look correct'; - - # normal tests in really_quiet mode - - @output = (); - _runtests( $harness_mute, "$source_tests/harness" ); - - chomp(@output); - @expected = ( - 'All tests successful.', - ); - - $status = pop @output; - $expected_status = qr{^Result: PASS$}; - $summary = pop @output; - $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; - - is_deeply \@output, \@expected, '... and the output should be correct'; - like $status, $expected_status, - '... and the status line should be correct'; - like $summary, $expected_summary, - '... and the report summary should look correct'; - - # normal tests with failures - - @output = (); - _runtests( $harness, "$source_tests/harness_failure" ); - - $status = pop @output; - $summary = pop @output; - - like $status, qr{^Result: FAIL$}, - '... and the status line should be correct'; - - my @summary = @output[ 18 .. $#output ]; - @output = @output[ 0 .. 17 ]; - - @expected = ( - "$source_tests/harness_failure ..", - '1..2', - '[[reset]]', - 'ok 1 - this is a test', - '[[reset]]', - '[[red]]', - 'not ok 2 - this is another test', - '[[reset]]', - q{# Failed test 'this is another test'}, - '[[reset]]', - '# in harness_failure.t at line 5.', - '[[reset]]', - q{# got: 'waffle'}, - '[[reset]]', - q{# expected: 'yarblokos'}, - '[[reset]]', - '[[red]]', - 'Failed 1/2 subtests', - ); - - is_deeply \@output, \@expected, - '... and failing test output should be correct'; - - my @expected_summary = ( - '[[reset]]', - 'Test Summary Report', - '-------------------', - '[[red]]', - "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", - '[[reset]]', - '[[red]]', - 'Failed test:', - '[[reset]]', - '[[red]]', - '2', - '[[reset]]', - ); - - is_deeply \@summary, \@expected_summary, - '... and the failure summary should also be correct'; - - # quiet tests with failures - - @output = (); - _runtests( $harness_whisper, "$source_tests/harness_failure" ); - - $status = pop @output; - $summary = pop @output; - @expected = ( - "$source_tests/harness_failure ..", - 'Failed 1/2 subtests', - 'Test Summary Report', - '-------------------', - "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", - 'Failed test:', - '2', - ); - - like $status, qr{^Result: FAIL$}, - '... and the status line should be correct'; - - is_deeply \@output, \@expected, - '... and failing test output should be correct'; - - # really quiet tests with failures - - @output = (); - _runtests( $harness_mute, "$source_tests/harness_failure" ); - - $status = pop @output; - $summary = pop @output; - @expected = ( - 'Test Summary Report', - '-------------------', - "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", - 'Failed test:', - '2', - ); - - like $status, qr{^Result: FAIL$}, - '... and the status line should be correct'; - - is_deeply \@output, \@expected, - '... and failing test output should be correct'; - - # only show directives - - @output = (); - _runtests( - $harness_directives, - "$source_tests/harness_directives" - ); - - chomp(@output); - - @expected = ( - "$source_tests/harness_directives ..", - 'not ok 2 - we have a something # TODO some output', - "ok 3 houston, we don't have liftoff # SKIP no funding", - 'ok', - 'All tests successful.', - - # ~TODO {{{ this should be an option - #'Test Summary Report', - #'-------------------', - #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)", - #'Tests skipped:', - #'3', - # }}} - ); - - $status = pop @output; - $summary = pop @output; - $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/; - - is_deeply \@output, \@expected, '... and the output should be correct'; - like $summary, $expected_summary, - '... and the report summary should look correct'; - - like $status, qr{^Result: PASS$}, - '... and the status line should be correct'; - - # normal tests with bad tap - - # install callback handler - my $parser; - my $callback_count = 0; - - my @callback_log = (); - - for my $evt (qw(parser_args made_parser before_runtests after_runtests)) { - $harness->callback( - $evt => sub { - push @callback_log, $evt; - } - ); - } - - $harness->callback( - made_parser => sub { - $parser = shift; - $callback_count++; - } - ); - - @output = (); - _runtests( $harness, "$source_tests/harness_badtap" ); - chomp(@output); - - @output = map { trim($_) } @output; - $status = pop @output; - @summary = @output[ 12 .. ( $#output - 1 ) ]; - @output = @output[ 0 .. 11 ]; - @expected = ( - "$source_tests/harness_badtap ..", - '1..2', - '[[reset]]', - 'ok 1 - this is a test', - '[[reset]]', - '[[red]]', - 'not ok 2 - this is another test', - '[[reset]]', - '1..2', - '[[reset]]', - '[[red]]', - 'Failed 1/2 subtests', - ); - is_deeply \@output, \@expected, - '... and failing test output should be correct'; - like $status, qr{^Result: FAIL$}, - '... and the status line should be correct'; - @expected_summary = ( - '[[reset]]', - 'Test Summary Report', - '-------------------', - '[[red]]', - "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)", - '[[reset]]', - '[[red]]', - 'Failed test:', - '[[reset]]', - '[[red]]', - '2', - '[[reset]]', - '[[red]]', - 'Parse errors: More than one plan found in TAP output', - '[[reset]]', - ); - is_deeply \@summary, \@expected_summary, - '... and the badtap summary should also be correct'; - - cmp_ok( $callback_count, '==', 1, 'callback called once' ); - is_deeply( - \@callback_log, - [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ], - 'callback log matches' - ); - isa_ok $parser, 'TAP::Parser'; - - # coverage testing for _should_show_failures - # only show failures - - @output = (); - _runtests( $harness_failures, "$source_tests/harness_failure" ); - - chomp(@output); - - @expected = ( - "$source_tests/harness_failure ..", - 'not ok 2 - this is another test', - 'Failed 1/2 subtests', - 'Test Summary Report', - '-------------------', - "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", - 'Failed test:', - '2', - ); - - $status = pop @output; - $summary = pop @output; - - like $status, qr{^Result: FAIL$}, - '... and the status line should be correct'; - $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; - is_deeply \@output, \@expected, '... and the output should be correct'; - - # check the status output for no tests - - @output = (); - _runtests( $harness_failures, "$sample_tests/no_output" ); - - chomp(@output); - - @expected = ( - "$sample_tests/no_output ..", - 'No subtests run', - 'Test Summary Report', - '-------------------', - "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)", - 'Parse errors: No plan found in TAP output', - ); - - $status = pop @output; - $summary = pop @output; - - like $status, qr{^Result: FAIL$}, - '... and the status line should be correct'; - $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; - is_deeply \@output, \@expected, '... and the output should be correct'; - - #XXXX -} - -# make sure we can exec something ... anything! -SKIP: { - - my $cat = '/bin/cat'; - 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' - ); -} - -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 - - # the coverage tests are - # 1. ref $ref => false - # 2. ref => ! GLOB and ref->can(print) - # 3. ref $ref => GLOB - - # case 1 - - 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'; - - # case 2 - - @die = (); - - 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'; - - # case 3 - - @die = (); - - $harness = TAP::Harness->new( - { stdout => bless {}, 'GLOB', # again with the evil - } - ); - - isa_ok $harness, 'TAP::Harness'; -} - -{ - - # 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}; - } -} diff --git a/ext/Test-Harness/t/iterators.t b/ext/Test-Harness/t/iterators.t deleted file mode 100644 index d190be9289..0000000000 --- a/ext/Test-Harness/t/iterators.t +++ /dev/null @@ -1,215 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use lib 't/lib'; - -use Test::More tests => 76; - -use File::Spec; -use TAP::Parser; -use TAP::Parser::IteratorFactory; -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 $/; <DATA> }; -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 vars qw( @ISA ); -@ISA = 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}; -} - -my $factory = TAP::Parser::IteratorFactory->new; -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 $iter - = $class - ? $class->new($source) - : $factory->make_iterator($source); - ok $iter, "$name: We should be able to create a new iterator"; - isa_ok $iter, 'TAP::Parser::Iterator', - '... and the object it returns'; - isa_ok $iter, $subclass, '... and the object it returns'; - - can_ok $iter, 'exit'; - ok !defined $iter->exit, - "$name: ... and it should be undef before we are done ($subclass)"; - - can_ok $iter, 'next'; - is $iter->next, 'one', "$name: next() should return the first result"; - - is $iter->next, 'two', - "$name: next() should return the second result"; - - is $iter->next, '', "$name: next() should return the third result"; - - is $iter->next, 'three', - "$name: next() should return the fourth result"; - - ok !defined $iter->next, - "$name: next() should return undef after it is empty"; - - is $iter->exit, 0, - "$name: ... and exit should now return 0 ($subclass)"; - - is $iter->wait, 0, "$name: wait should also now return 0 ($subclass)"; - - if ( my $after = $test->{after} ) { - $after->(); - } - } -} - -{ - - # coverage tests for the ctor - - my $stream = $factory->make_iterator( IO::Handle->new ); - - isa_ok $stream, 'TAP::Parser::Iterator::Stream'; - - my @die; - - eval { - local $SIG{__DIE__} = sub { push @die, @_ }; - - $factory->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 $stream = $factory->make_iterator( - [ 'not ', - 'ok 1 - I hate VMS', - ] - ); - - is $stream->next, 'not ok 1 - I hate VMS', - 'coverage of VMS line-splitting case'; - - # coverage test for VMS case - nothing after 'not' - - $stream = $factory->make_iterator( - [ 'not ', - ] - ); - - is $stream->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, @_ }; - - $factory->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 = $factory->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; -} -__DATA__ -one -two - -three diff --git a/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm b/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm deleted file mode 100644 index 81f79ea042..0000000000 --- a/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm +++ /dev/null @@ -1,9 +0,0 @@ -package App::Prove::Plugin::Dummy; - -use strict; - -sub import { - main::test_log_import(@_); -} - -1; diff --git a/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm b/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm deleted file mode 100644 index ae80003e62..0000000000 --- a/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm +++ /dev/null @@ -1,13 +0,0 @@ -package App::Prove::Plugin::Dummy2; - -use strict; - -sub import { - main::test_log_import(@_); -} - -sub load { - main::test_log_plugin_load(@_); -} - -1; diff --git a/ext/Test-Harness/t/lib/Dev/Null.pm b/ext/Test-Harness/t/lib/Dev/Null.pm deleted file mode 100644 index 09ca5d6627..0000000000 --- a/ext/Test-Harness/t/lib/Dev/Null.pm +++ /dev/null @@ -1,18 +0,0 @@ -# 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; diff --git a/ext/Test-Harness/t/lib/EmptyParser.pm b/ext/Test-Harness/t/lib/EmptyParser.pm deleted file mode 100644 index 2f7ec2428e..0000000000 --- a/ext/Test-Harness/t/lib/EmptyParser.pm +++ /dev/null @@ -1,30 +0,0 @@ -package EmptyParser; - -use strict; -use vars qw(@ISA); - -use TAP::Parser (); - -@ISA = 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( source_class perl_source_class grammar_class - iterator_factory_class result_factory_class ) - ) - { - my $default_method = "_default_$key"; - $self->$key( $self->$default_method() ); - } - - return $self; -} - -1; diff --git a/ext/Test-Harness/t/lib/IO/c55Capture.pm b/ext/Test-Harness/t/lib/IO/c55Capture.pm deleted file mode 100644 index ecbcb49ba7..0000000000 --- a/ext/Test-Harness/t/lib/IO/c55Capture.pm +++ /dev/null @@ -1,120 +0,0 @@ -package 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 diff --git a/ext/Test-Harness/t/lib/MyCustom.pm b/ext/Test-Harness/t/lib/MyCustom.pm deleted file mode 100644 index 2402312edc..0000000000 --- a/ext/Test-Harness/t/lib/MyCustom.pm +++ /dev/null @@ -1,12 +0,0 @@ -# avoid cut-n-paste exhaustion with this mixin - -package MyCustom; -use strict; - -sub custom { - my $self = shift; - $main::CUSTOM{ ref($self) }++; - return $self; -} - -1; diff --git a/ext/Test-Harness/t/lib/MyGrammar.pm b/ext/Test-Harness/t/lib/MyGrammar.pm deleted file mode 100644 index ef93f9dfc1..0000000000 --- a/ext/Test-Harness/t/lib/MyGrammar.pm +++ /dev/null @@ -1,21 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyGrammar; - -use strict; -use vars '@ISA'; - -use MyCustom; -use TAP::Parser::Grammar; - -@ISA = qw( TAP::Parser::Grammar MyCustom ); - -sub _initialize { - my $self = shift; - $self->SUPER::_initialize(@_); - $main::INIT{ ref($self) }++; - $self->{initialized} = 1; - return $self; -} - -1; diff --git a/ext/Test-Harness/t/lib/MyIterator.pm b/ext/Test-Harness/t/lib/MyIterator.pm deleted file mode 100644 index 561f6e2c78..0000000000 --- a/ext/Test-Harness/t/lib/MyIterator.pm +++ /dev/null @@ -1,26 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyIterator; - -use strict; -use vars '@ISA'; - -use MyCustom; -use TAP::Parser::Iterator; - -@ISA = 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; diff --git a/ext/Test-Harness/t/lib/MyIteratorFactory.pm b/ext/Test-Harness/t/lib/MyIteratorFactory.pm deleted file mode 100644 index d8c3269cda..0000000000 --- a/ext/Test-Harness/t/lib/MyIteratorFactory.pm +++ /dev/null @@ -1,19 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyIteratorFactory; - -use strict; -use vars '@ISA'; - -use MyCustom; -use MyIterator; -use TAP::Parser::IteratorFactory; - -@ISA = qw( TAP::Parser::IteratorFactory MyCustom ); - -sub make_iterator { - my $class = shift; - return MyIterator->new(@_); -} - -1; diff --git a/ext/Test-Harness/t/lib/MyPerlSource.pm b/ext/Test-Harness/t/lib/MyPerlSource.pm deleted file mode 100644 index 6193db97df..0000000000 --- a/ext/Test-Harness/t/lib/MyPerlSource.pm +++ /dev/null @@ -1,27 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyPerlSource; - -use strict; -use vars '@ISA'; - -use MyCustom; -use TAP::Parser::Source::Perl; - -@ISA = qw( TAP::Parser::Source::Perl MyCustom ); - -sub _initialize { - my $self = shift; - $self->SUPER::_initialize(@_); - $main::INIT{ ref($self) }++; - $self->{initialized} = 1; - return $self; -} - -sub source { - my $self = shift; - return $self->SUPER::source(@_); -} - -1; - diff --git a/ext/Test-Harness/t/lib/MyResult.pm b/ext/Test-Harness/t/lib/MyResult.pm deleted file mode 100644 index ab4845dedf..0000000000 --- a/ext/Test-Harness/t/lib/MyResult.pm +++ /dev/null @@ -1,21 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyResult; - -use strict; -use vars '@ISA'; - -use MyCustom; -use TAP::Parser::Result; - -@ISA = qw( TAP::Parser::Result MyCustom ); - -sub _initialize { - my $self = shift; - $self->SUPER::_initialize(@_); - $main::INIT{ ref($self) }++; - $self->{initialized} = 1; - return $self; -} - -1; diff --git a/ext/Test-Harness/t/lib/MyResultFactory.pm b/ext/Test-Harness/t/lib/MyResultFactory.pm deleted file mode 100644 index 371bba632b..0000000000 --- a/ext/Test-Harness/t/lib/MyResultFactory.pm +++ /dev/null @@ -1,23 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyResultFactory; - -use strict; -use vars '@ISA'; - -use MyCustom; -use MyResult; -use TAP::Parser::ResultFactory; - -@ISA = 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; diff --git a/ext/Test-Harness/t/lib/MySource.pm b/ext/Test-Harness/t/lib/MySource.pm deleted file mode 100644 index 5e41b829ae..0000000000 --- a/ext/Test-Harness/t/lib/MySource.pm +++ /dev/null @@ -1,34 +0,0 @@ -# subclass for testing customizing & subclassing - -package MySource; - -use strict; -use vars '@ISA'; - -use MyCustom; -use TAP::Parser::Source; - -@ISA = qw( TAP::Parser::Source MyCustom ); - -sub _initialize { - my $self = shift; - $self->SUPER::_initialize(@_); - $main::INIT{ ref($self) }++; - $self->{initialized} = 1; - return $self; -} - -sub source { - my $self = shift; - return $self->SUPER::source(@_); -} - -sub get_stream { - my $self = shift; - my $stream = $self->SUPER::get_stream(@_); - - # re-bless it: - bless $stream, 'MyIterator'; -} - -1; diff --git a/ext/Test-Harness/t/lib/NOP.pm b/ext/Test-Harness/t/lib/NOP.pm deleted file mode 100644 index 6de1dbfbd5..0000000000 --- a/ext/Test-Harness/t/lib/NOP.pm +++ /dev/null @@ -1,7 +0,0 @@ -package NOP; - -# Do nothing much - -sub new { bless {}, shift } - -1; diff --git a/ext/Test-Harness/t/lib/NoFork.pm b/ext/Test-Harness/t/lib/NoFork.pm deleted file mode 100644 index 0225e9628d..0000000000 --- a/ext/Test-Harness/t/lib/NoFork.pm +++ /dev/null @@ -1,21 +0,0 @@ -package 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 diff --git a/ext/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm b/ext/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm deleted file mode 100644 index 84becee932..0000000000 --- a/ext/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm +++ /dev/null @@ -1,39 +0,0 @@ -# subclass for testing subclassing - -package TAP::Parser::SubclassTest; - -use strict; -use vars qw(@ISA); - -use TAP::Parser; - -use MyCustom; -use MySource; -use MyPerlSource; -use MyGrammar; -use MyIteratorFactory; -use MyResultFactory; - -@ISA = qw( TAP::Parser MyCustom ); - -sub _default_source_class {'MySource'} -sub _default_perl_source_class {'MyPerlSource'} -sub _default_grammar_class {'MyGrammar'} -sub _default_iterator_factory_class {'MyIteratorFactory'} -sub _default_result_factory_class {'MyResultFactory'} - -sub make_source { shift->SUPER::make_source(@_)->custom } -sub make_perl_source { shift->SUPER::make_perl_source(@_)->custom } -sub make_grammar { shift->SUPER::make_grammar(@_)->custom } -sub make_iterator { shift->SUPER::make_iterator(@_)->custom } -sub make_result { shift->SUPER::make_result(@_)->custom } - -sub _initialize { - my $self = shift; - $self->SUPER::_initialize(@_); - $main::INIT{ ref($self) }++; - $self->{initialized} = 1; - return $self; -} - -1; diff --git a/ext/Test-Harness/t/multiplexer.t b/ext/Test-Harness/t/multiplexer.t deleted file mode 100644 index 649d5d161f..0000000000 --- a/ext/Test-Harness/t/multiplexer.t +++ /dev/null @@ -1,170 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -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; diff --git a/ext/Test-Harness/t/nofork-mux.t b/ext/Test-Harness/t/nofork-mux.t deleted file mode 100644 index 4f28bf8c1d..0000000000 --- a/ext/Test-Harness/t/nofork-mux.t +++ /dev/null @@ -1,10 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - use lib 't/lib'; -} - -use strict; - -use NoFork; -require( 't/multiplexer.t' ); diff --git a/ext/Test-Harness/t/nofork.t b/ext/Test-Harness/t/nofork.t deleted file mode 100644 index 1d8b340e1b..0000000000 --- a/ext/Test-Harness/t/nofork.t +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/perl -w - -# check nofork logic on systems which *can* fork() -# NOTE maybe a good candidate for xt/author or something. - -use lib 't/lib'; - -use strict; - -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 diff --git a/ext/Test-Harness/t/object.t b/ext/Test-Harness/t/object.t deleted file mode 100644 index b1a4dd0b98..0000000000 --- a/ext/Test-Harness/t/object.t +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -use lib 't/lib'; - -use Test::More tests => 7; - -use_ok('TAP::Object'); - -can_ok( 'TAP::Object', 'new' ); -can_ok( 'TAP::Object', '_initialize' ); -can_ok( 'TAP::Object', '_croak' ); - -{ - - package TAP::TestObj; - use vars qw(@ISA); - @ISA = qw(TAP::Object); - - sub _initialize { - my $self = shift; - $self->{init} = 1; - $self->{args} = [@_]; - return $self; - } -} - -# I know these tests are simple, but they're documenting the base API, so -# necessary none-the-less... -my $obj = TAP::TestObj->new( 'foo', { bar => 'baz' } ); -ok( $obj->{init}, '_initialize' ); -is_deeply( $obj->{args}, [ 'foo', { bar => 'baz' } ], '_initialize: args' ); - -eval { $obj->_croak('eek') }; -my $err = $@; -like( $err, qr/^eek/, '_croak' ); - diff --git a/ext/Test-Harness/t/parse.t b/ext/Test-Harness/t/parse.t deleted file mode 100644 index f0def28c9a..0000000000 --- a/ext/Test-Harness/t/parse.t +++ /dev/null @@ -1,1058 +0,0 @@ -#!/usr/bin/perl -w - -use strict; - -use lib 't/lib'; - -use Test::More tests => 294; -use IO::c55Capture; - -use File::Spec; - -use TAP::Parser; -use TAP::Parser::IteratorFactory; - -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 $factory = TAP::Parser::IteratorFactory->new; - -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( { stream => $factory->make_iterator($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 stream at/, - '...and it failed as expected'; - - @die = (); - - eval { - local $SIG{__DIE__} = sub { push @die, @_ }; - - $PARSER->new( - { stream => 'stream', - 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', 'stream', 'tap' or 'source'/, - '...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->_stream, 'TAP::Parser::Iterator::Array'; - - # 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 determine source for 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->_stream, 'TAP::Parser::Iterator::Process'; - - # Workaround for Mac OS X problem wrt closing the iterator without - # reading from it. - $parser->next; -} - -{ - - # coverage testing for TAP::Parser::has_problems - - # we're going to need to test lots of fragments of tap - # to cover all the different boolean tests - - # currently covered are no problems and failed, so let's next test - # todo_passed - - my $tap = <<'END_TAP'; -TAP version 13 -1..2 -ok 1 - input file opened -ok 2 - Gandalf wins. Game over. # TODO 'bout time! -END_TAP - - my $parser = TAP::Parser->new( { tap => $tap } ); - - _get_results($parser); - - ok !$parser->failed, 'parser didnt fail'; - ok $parser->todo_passed, '... and todo_passed is true'; - - ok !$parser->has_problems, '... and has_problems is false'; - - # now parse_errors - - $tap = <<'END_TAP'; -TAP version 13 -1..2 -SMACK -END_TAP - - $parser = TAP::Parser->new( { tap => $tap } ); - - _get_results($parser); - - ok !$parser->failed, 'parser didnt fail'; - ok !$parser->todo_passed, '... and todo_passed is false'; - ok $parser->parse_errors, '... and parse_errors is true'; - - ok $parser->has_problems, '... and has_problems'; - - # Now wait and exit are hard to do in an OS platform-independent way, so - # we won't even bother - - $tap = <<'END_TAP'; -TAP version 13 -1..2 -ok 1 - input file opened -ok 2 - Gandalf wins -END_TAP - - $parser = TAP::Parser->new( { tap => $tap } ); - - _get_results($parser); - - $parser->wait(1); - - ok !$parser->failed, 'parser didnt fail'; - ok !$parser->todo_passed, '... and todo_passed is false'; - ok !$parser->parse_errors, '... and parse_errors is false'; - - ok $parser->wait, '... and wait is set'; - - ok $parser->has_problems, '... and has_problems'; - - # and use the same for exit - - $parser->wait(0); - $parser->exit(1); - - ok !$parser->failed, 'parser didnt fail'; - ok !$parser->todo_passed, '... and todo_passed is false'; - ok !$parser->parse_errors, '... and parse_errors is false'; - ok !$parser->wait, '... and wait is not set'; - - ok $parser->exit, '... and exit is set'; - - ok $parser->has_problems, '... and has_problems'; -} - -{ - - # coverage testing of the version states - - my $tap = <<'END_TAP'; -TAP version 12 -1..2 -ok 1 - input file opened -ok 2 - Gandalf wins -END_TAP - - my $parser = TAP::Parser->new( { tap => $tap } ); - - _get_results($parser); - - my @errors = $parser->parse_errors; - - is @errors, 1, 'test too low version number'; - - like pop @errors, - qr/Explicit TAP version must be at least 13. Got version 12/, - '... and trapped expected version error'; - - # now too high a version - $tap = <<'END_TAP'; -TAP version 14 -1..2 -ok 1 - input file opened -ok 2 - Gandalf wins -END_TAP - - $parser = TAP::Parser->new( { tap => $tap } ); - - _get_results($parser); - - @errors = $parser->parse_errors; - - is @errors, 1, 'test too high version number'; - - like pop @errors, - qr/TAP specified version 14 but we don't know about versions later than 13/, - '... and trapped expected version error'; -} - -{ - - # coverage testing of TAP version in the wrong place - - my $tap = <<'END_TAP'; -1..2 -ok 1 - input file opened -TAP version 12 -ok 2 - Gandalf wins -END_TAP - - my $parser = TAP::Parser->new( { tap => $tap } ); - - _get_results($parser); - - my @errors = $parser->parse_errors; - - is @errors, 1, 'test TAP version number in wrong place'; - - like pop @errors, - qr/If TAP version is present it must be the first line of output/, - '... and trapped expected version error'; - -} - -{ - - # we're going to bash the internals a bit (but using the API as - # much as possible) to force grammar->tokenise() to fail - - # firstly we'll create a stream that dies when its next_raw method is called - - package TAP::Parser::Iterator::Dies; - - use strict; - use vars qw(@ISA); - - @ISA = 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 stream - my $stream = TAP::Parser::Iterator::Dies->new; - - # now replace the stream - we're forced to us an T::P intenal - # method for this - $parser->_stream($stream); - - # build a new grammar - my $grammar = TAP::Parser::Grammar->new( - { stream => $stream, - 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 stream - my $stream = TAP::Parser::Iterator::Dies->new; - - # now replace the stream - we're forced to us an T::P intenal - # method for this - $parser->_stream($stream); - - # build a new grammar - my $grammar = TAP::Parser::Grammar->new( - { stream => $stream, - 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 vars qw(@ISA); - - @ISA = 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 vars qw(@ISA); - - @ISA = 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 } - ) - ); - } -} diff --git a/ext/Test-Harness/t/parser-config.t b/ext/Test-Harness/t/parser-config.t deleted file mode 100644 index bd3625902d..0000000000 --- a/ext/Test-Harness/t/parser-config.t +++ /dev/null @@ -1,39 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; -use vars qw(%INIT %CUSTOM); - -use Test::More tests => 11; -use File::Spec::Functions qw( catfile updir ); -use TAP::Parser; - -use_ok('MySource'); -use_ok('MyPerlSource'); -use_ok('MyGrammar'); -use_ok('MyIteratorFactory'); -use_ok('MyResultFactory'); - -my $source = catfile( 't', 'source_tests', 'source' ); -my %customize = ( - source_class => 'MySource', - perl_source_class => 'MyPerlSource', - grammar_class => 'MyGrammar', - iterator_factory_class => 'MyIteratorFactory', - result_factory_class => 'MyResultFactory', -); -my $p = TAP::Parser->new( - { source => $source, - %customize, - } -); -ok( $p, 'new customized parser' ); - -foreach my $key ( keys %customize ) { - is( $p->$key(), $customize{$key}, "customized $key" ); -} - -# TODO: make sure these things are propogated down through the parser... diff --git a/ext/Test-Harness/t/parser-subclass.t b/ext/Test-Harness/t/parser-subclass.t deleted file mode 100644 index 303c28ca27..0000000000 --- a/ext/Test-Harness/t/parser-subclass.t +++ /dev/null @@ -1,80 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; -use vars qw(%INIT %CUSTOM); - -use Test::More tests => 24; -use File::Spec::Functions qw( catfile updir ); - -use_ok('TAP::Parser::SubclassTest'); - -# TODO: foreach my $source ( ... ) -{ # perl source - %INIT = %CUSTOM = (); - my $source = catfile( '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->source_class => 'MySource', 'source_class' ); - is( $p->perl_source_class => 'MyPerlSource', 'perl_source_class' ); - is( $p->grammar_class => 'MyGrammar', 'grammar_class' ); - is( $p->iterator_factory_class => 'MyIteratorFactory', - 'iterator_factory_class' - ); - is( $p->result_factory_class => 'MyResultFactory', - 'result_factory_class' - ); - - is( $INIT{MyPerlSource}, 1, 'initialized MyPerlSource' ); - is( $CUSTOM{MyPerlSource}, 1, '... and it was customized' ); - is( $INIT{MyGrammar}, 1, 'initialized MyGrammar' ); - is( $CUSTOM{MyGrammar}, 1, '... and it was customized' ); - - # make sure overrided make_* methods work... - %CUSTOM = (); - $p->make_source; - is( $CUSTOM{MySource}, 1, 'make custom source' ); - $p->make_perl_source; - is( $CUSTOM{MyPerlSource}, 1, 'make custom perl source' ); - $p->make_grammar; - is( $CUSTOM{MyGrammar}, 1, 'make custom grammar' ); - $p->make_iterator; - is( $CUSTOM{MyIterator}, 1, 'make custom iterator' ); - $p->make_result; - is( $CUSTOM{MyResult}, 1, 'make custom result' ); - - # make sure parser helpers use overrided classes too (the parser should - # be the central source of configuration/overriding functionality) - # The source is already tested above (parser doesn't keep a copy of the - # source currently). So only one to check is the Grammar: - %INIT = %CUSTOM = (); - my $r = $p->_grammar->tokenize; - isa_ok( $r, 'MyResult', 'i has results' ); - is( $INIT{MyResult}, 1, 'initialized MyResult' ); - is( $CUSTOM{MyResult}, 1, '... and it was customized' ); - is( $INIT{MyResultFactory}, 1, '"initialized" MyResultFactory' ); -} - -SKIP: { # non-perl source - %INIT = %CUSTOM = (); - my $cat = '/bin/cat'; - unless ( -e $cat ) { - skip "no '$cat'", 4; - } - my $file = catfile( 't', 'data', 'catme.1' ); - my $p = TAP::Parser::SubclassTest->new( { exec => [ $cat => $file ] } ); - - is( $INIT{MySource}, 1, 'initialized MySource subclass' ); - is( $CUSTOM{MySource}, 1, '... and it was customized' ); - is( $INIT{MyIterator}, 1, 'initialized MyIterator subclass' ); - is( $CUSTOM{MyIterator}, 1, '... and it was customized' ); -} diff --git a/ext/Test-Harness/t/perl5lib.t b/ext/Test-Harness/t/perl5lib.t deleted file mode 100644 index 51113e156b..0000000000 --- a/ext/Test-Harness/t/perl5lib.t +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/perl -w - -# Test that PERL5LIB is propogated from the harness process to the test -# process. - -use strict; -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{PERL_CORE} ? '../lib' : () ), $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; diff --git a/ext/Test-Harness/t/premature-bailout.t b/ext/Test-Harness/t/premature-bailout.t deleted file mode 100644 index 9226a44064..0000000000 --- a/ext/Test-Harness/t/premature-bailout.t +++ /dev/null @@ -1,125 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -use lib 't/lib'; - -use Test::More tests => 14; - -use TAP::Parser; -use TAP::Parser::IteratorFactory; - -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 $factory = TAP::Parser::IteratorFactory->new; -my $parser = TAP::Parser->new( - { stream => $factory->make_iterator( 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( - { stream => $factory->make_iterator( [ 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"; - diff --git a/ext/Test-Harness/t/process.t b/ext/Test-Harness/t/process.t deleted file mode 100644 index 5135d67f95..0000000000 --- a/ext/Test-Harness/t/process.t +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -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"; - } -} diff --git a/ext/Test-Harness/t/prove.t b/ext/Test-Harness/t/prove.t deleted file mode 100644 index 71730cdbf6..0000000000 --- a/ext/Test-Harness/t/prove.t +++ /dev/null @@ -1,1525 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; - -use Test::More; -use File::Spec; - -use App::Prove; - -package FakeProve; -use vars qw( @ISA ); - -@ISA = qw( App::Prove ); - -sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - $self->{_log} = []; - return $self; -} - -sub _color_default {0} - -sub _runtests { - my $self = shift; - push @{ $self->{_log} }, [ '_runtests', @_ ]; -} - -sub get_log { - my $self = shift; - my @log = @{ $self->{_log} }; - $self->{_log} = []; - return @log; -} - -sub _shuffle { - my $self = shift; - s/^/xxx/ for @_; -} - -package main; - -sub mabs { - my $ar = shift; - return [ map { File::Spec->rel2abs($_) } @$ar ]; -} - -{ - my @import_log = (); - sub test_log_import { push @import_log, [@_] } - - sub get_import_log { - my @log = @import_log; - @import_log = (); - return @log; - } - - my @plugin_load_log = (); - sub test_log_plugin_load { push @plugin_load_log, [@_] } - - sub get_plugin_load_log { - my @log = @plugin_load_log; - @plugin_load_log = (); - return @log; - } -} - -my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE ); - -# see the "ACTUAL TEST" section at the bottom - -BEGIN { # START PLAN - - # list of attributes - @ATTR = qw( - archive argv blib color directives exec extension failures - formatter harness includes lib merge parse quiet really_quiet - recurse backwards shuffle taint_fail taint_warn verbose - warnings_fail warnings_warn - ); - - # what we expect if the 'expect' hash does not define it - %DEFAULT_ASSERTION = map { $_ => undef } @ATTR; - - $DEFAULT_ASSERTION{includes} = $DEFAULT_ASSERTION{argv} - = sub { 'ARRAY' eq ref shift }; - - my @dummy_tests = map { File::Spec->catdir( 't', 'sample-tests', $_ ) } - qw(simple simple_yaml); - my $dummy_test = $dummy_tests[0]; - - ######################################################################## - # declarations - this drives all of the subtests. - # The cheatsheet follows. - # required: name, expect - # optional: - # args - arguments to constructor - # switches - command-line switches - # runlog - expected results of internal calls to _runtests, must - # match FakeProve's _log attr - # run_error - depends on 'runlog' (if missing, asserts no error) - # extra - follow-up check to handle exceptional cleanup / verification - # class - The App::Prove subclass to test. Defaults to FakeProve - @SCHEDULE = ( - { name => 'Create empty', - expect => {} - }, - { name => 'Set all options via constructor', - args => { - archive => 1, - argv => [qw(one two three)], - blib => 2, - color => 3, - directives => 4, - exec => 5, - failures => 7, - formatter => 8, - harness => 9, - includes => [qw(four five six)], - lib => 10, - merge => 11, - parse => 13, - quiet => 14, - really_quiet => 15, - recurse => 16, - backwards => 17, - shuffle => 18, - taint_fail => 19, - taint_warn => 20, - verbose => 21, - warnings_fail => 22, - warnings_warn => 23, - }, - expect => { - archive => 1, - argv => [qw(one two three)], - blib => 2, - color => 3, - directives => 4, - exec => 5, - failures => 7, - formatter => 8, - harness => 9, - includes => [qw(four five six)], - lib => 10, - merge => 11, - parse => 13, - quiet => 14, - really_quiet => 15, - recurse => 16, - backwards => 17, - shuffle => 18, - taint_fail => 19, - taint_warn => 20, - verbose => 21, - warnings_fail => 22, - warnings_warn => 23, - } - }, - { name => 'Call with defaults', - args => { argv => [qw( one two three )] }, - expect => {}, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - - # Test all options individually - - # { name => 'Just archive', - # args => { - # argv => [qw( one two three )], - # archive => 1, - # }, - # expect => { - # archive => 1, - # }, - # runlog => [ - # [ { archive => 1, - # }, - # 'TAP::Harness', - # 'one', 'two', - # 'three' - # ] - # ], - # }, - { name => 'Just argv', - args => { - argv => [qw( one two three )], - }, - expect => { - argv => [qw( one two three )], - }, - runlog => [ - [ '_runtests', - { verbosity => 0, show_count => 1 }, - 'TAP::Harness', - 'one', 'two', - 'three' - ] - ], - }, - { name => 'Just blib', - args => { - argv => [qw( one two three )], - blib => 1, - }, - expect => { - blib => 1, - }, - runlog => [ - [ '_runtests', - { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - - { name => 'Just color', - args => { - argv => [qw( one two three )], - color => 1, - }, - expect => { - color => 1, - }, - runlog => [ - [ '_runtests', - { color => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - - { name => 'Just directives', - args => { - argv => [qw( one two three )], - directives => 1, - }, - expect => { - directives => 1, - }, - runlog => [ - [ '_runtests', - { directives => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just exec', - args => { - argv => [qw( one two three )], - exec => 1, - }, - expect => { - exec => 1, - }, - runlog => [ - [ '_runtests', - { exec => [1], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just failures', - args => { - argv => [qw( one two three )], - failures => 1, - }, - expect => { - failures => 1, - }, - runlog => [ - [ '_runtests', - { failures => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - - { name => 'Just formatter', - args => { - argv => [qw( one two three )], - formatter => 'TAP::Harness', - }, - expect => { - formatter => 'TAP::Harness', - }, - runlog => [ - [ '_runtests', - { formatter_class => 'TAP::Harness', - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - - { name => 'Just includes', - args => { - argv => [qw( one two three )], - includes => [qw( four five six )], - }, - expect => { - includes => [qw( four five six )], - }, - runlog => [ - [ '_runtests', - { lib => mabs( [qw( four five six )] ), - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just lib', - args => { - argv => [qw( one two three )], - lib => 1, - }, - expect => { - lib => 1, - }, - runlog => [ - [ '_runtests', - { lib => mabs( ['lib'] ), - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just merge', - args => { - argv => [qw( one two three )], - merge => 1, - }, - expect => { - merge => 1, - }, - runlog => [ - [ '_runtests', - { merge => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just parse', - args => { - argv => [qw( one two three )], - parse => 1, - }, - expect => { - parse => 1, - }, - runlog => [ - [ '_runtests', - { errors => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just quiet', - args => { - argv => [qw( one two three )], - quiet => 1, - }, - expect => { - quiet => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => -1, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just really_quiet', - args => { - argv => [qw( one two three )], - really_quiet => 1, - }, - expect => { - really_quiet => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => -2, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just recurse', - args => { - argv => [qw( one two three )], - recurse => 1, - }, - expect => { - recurse => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just reverse', - args => { - argv => [qw( one two three )], - backwards => 1, - }, - expect => { - backwards => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'three', 'two', 'one' - ] - ], - }, - - { name => 'Just shuffle', - args => { - argv => [qw( one two three )], - shuffle => 1, - }, - expect => { - shuffle => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'xxxone', 'xxxtwo', - 'xxxthree' - ] - ], - }, - { name => 'Just taint_fail', - args => { - argv => [qw( one two three )], - taint_fail => 1, - }, - expect => { - taint_fail => 1, - }, - runlog => [ - [ '_runtests', - { switches => ['-T'], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just taint_warn', - args => { - argv => [qw( one two three )], - taint_warn => 1, - }, - expect => { - taint_warn => 1, - }, - runlog => [ - [ '_runtests', - { switches => ['-t'], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just verbose', - args => { - argv => [qw( one two three )], - verbose => 1, - }, - expect => { - verbose => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => 1, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just warnings_fail', - args => { - argv => [qw( one two three )], - warnings_fail => 1, - }, - expect => { - warnings_fail => 1, - }, - runlog => [ - [ '_runtests', - { switches => ['-W'], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - { name => 'Just warnings_warn', - args => { - argv => [qw( one two three )], - warnings_warn => 1, - }, - expect => { - warnings_warn => 1, - }, - runlog => [ - [ '_runtests', - { switches => ['-w'], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - 'one', 'two', 'three' - ] - ], - }, - - # Command line parsing - { name => 'Switch -v', - args => { - argv => [qw( one two three )], - }, - switches => [ '-v', $dummy_test ], - expect => { - verbose => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => 1, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --verbose', - args => { - argv => [qw( one two three )], - }, - switches => [ '--verbose', $dummy_test ], - expect => { - verbose => 1, - }, - runlog => [ - [ '_runtests', - { verbosity => 1, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -f', - args => { - argv => [qw( one two three )], - }, - switches => [ '-f', $dummy_test ], - expect => { failures => 1 }, - runlog => [ - [ '_runtests', - { failures => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --failures', - args => { - argv => [qw( one two three )], - }, - switches => [ '--failures', $dummy_test ], - expect => { failures => 1 }, - runlog => [ - [ '_runtests', - { failures => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -l', - args => { - argv => [qw( one two three )], - }, - switches => [ '-l', $dummy_test ], - expect => { lib => 1 }, - runlog => [ - [ '_runtests', - { lib => mabs( ['lib'] ), - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --lib', - args => { - argv => [qw( one two three )], - }, - switches => [ '--lib', $dummy_test ], - expect => { lib => 1 }, - runlog => [ - [ '_runtests', - { lib => mabs( ['lib'] ), - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -b', - args => { - argv => [qw( one two three )], - }, - switches => [ '-b', $dummy_test ], - expect => { blib => 1 }, - runlog => [ - [ '_runtests', - { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --blib', - args => { - argv => [qw( one two three )], - }, - switches => [ '--blib', $dummy_test ], - expect => { blib => 1 }, - runlog => [ - [ '_runtests', - { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -s', - args => { - argv => [qw( one two three )], - }, - switches => [ '-s', $dummy_test ], - expect => { shuffle => 1 }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - "xxx$dummy_test" - ] - ], - }, - - { name => 'Switch --shuffle', - args => { - argv => [qw( one two three )], - }, - switches => [ '--shuffle', $dummy_test ], - expect => { shuffle => 1 }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - "xxx$dummy_test" - ] - ], - }, - - { name => 'Switch -c', - args => { - argv => [qw( one two three )], - }, - switches => [ '-c', $dummy_test ], - expect => { color => 1 }, - runlog => [ - [ '_runtests', - { color => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -r', - args => { - argv => [qw( one two three )], - }, - switches => [ '-r', $dummy_test ], - expect => { recurse => 1 }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --recurse', - args => { - argv => [qw( one two three )], - }, - switches => [ '--recurse', $dummy_test ], - expect => { recurse => 1 }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --reverse', - args => { - argv => [qw( one two three )], - }, - switches => [ '--reverse', @dummy_tests ], - expect => { backwards => 1 }, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - reverse @dummy_tests - ] - ], - }, - - { name => 'Switch -p', - args => { - argv => [qw( one two three )], - }, - switches => [ '-p', $dummy_test ], - expect => { - parse => 1, - }, - runlog => [ - [ '_runtests', - { errors => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --parse', - args => { - argv => [qw( one two three )], - }, - switches => [ '--parse', $dummy_test ], - expect => { - parse => 1, - }, - runlog => [ - [ '_runtests', - { errors => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -q', - args => { - argv => [qw( one two three )], - }, - switches => [ '-q', $dummy_test ], - expect => { quiet => 1 }, - runlog => [ - [ '_runtests', - { verbosity => -1, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --quiet', - args => { - argv => [qw( one two three )], - }, - switches => [ '--quiet', $dummy_test ], - expect => { quiet => 1 }, - runlog => [ - [ '_runtests', - { verbosity => -1, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -Q', - args => { - argv => [qw( one two three )], - }, - switches => [ '-Q', $dummy_test ], - expect => { really_quiet => 1 }, - runlog => [ - [ '_runtests', - { verbosity => -2, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --QUIET', - args => { - argv => [qw( one two three )], - }, - switches => [ '--QUIET', $dummy_test ], - expect => { really_quiet => 1 }, - runlog => [ - [ '_runtests', - { verbosity => -2, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch -m', - args => { - argv => [qw( one two three )], - }, - switches => [ '-m', $dummy_test ], - expect => { merge => 1 }, - runlog => [ - [ '_runtests', - { merge => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --merge', - args => { - argv => [qw( one two three )], - }, - switches => [ '--merge', $dummy_test ], - expect => { merge => 1 }, - runlog => [ - [ '_runtests', - { merge => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Switch --directives', - args => { - argv => [qw( one two three )], - }, - switches => [ '--directives', $dummy_test ], - expect => { directives => 1 }, - runlog => [ - [ '_runtests', - { directives => 1, - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - # .proverc - { name => 'Empty exec in .proverc', - args => { - argv => [qw( one two three )], - }, - proverc => 't/proverc/emptyexec', - switches => [$dummy_test], - expect => { exec => '' }, - runlog => [ - [ '_runtests', - { exec => [], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - # Executing one word (why would it be a -s though?) - { name => 'Switch --exec -s', - args => { - argv => [qw( one two three )], - }, - switches => [ '--exec', '-s', $dummy_test ], - expect => { exec => '-s' }, - runlog => [ - [ '_runtests', - { exec => ['-s'], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - # multi-part exec - { name => 'Switch --exec "/foo/bar/perl -Ilib"', - args => { - argv => [qw( one two three )], - }, - switches => [ '--exec', '/foo/bar/perl -Ilib', $dummy_test ], - expect => { exec => '/foo/bar/perl -Ilib' }, - runlog => [ - [ '_runtests', - { exec => [qw(/foo/bar/perl -Ilib)], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - # null exec (run tests as compiled binaries) - { name => 'Switch --exec ""', - switches => [ '--exec', '', $dummy_test ], - expect => { - exec => # ick, must workaround the || default bit with a sub - sub { my $val = shift; defined($val) and !length($val) } - }, - runlog => [ - [ '_runtests', - { exec => [], - verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - # Plugins - { name => 'Load plugin', - switches => [ '-P', 'Dummy', $dummy_test ], - args => { - argv => [qw( one two three )], - }, - expect => { - plugins => ['Dummy'], - }, - extra => sub { - my @loaded = get_import_log(); - is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], - "Plugin loaded OK"; - }, - plan => 1, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Load plugin (args)', - switches => [ '-P', 'Dummy=cracking,cheese,gromit', $dummy_test ], - args => { - argv => [qw( one two three )], - }, - expect => { - plugins => ['Dummy'], - }, - extra => sub { - my @loaded = get_import_log(); - is_deeply \@loaded, - [ [ 'App::Prove::Plugin::Dummy', 'cracking', 'cheese', - 'gromit' - ] - ], - "Plugin loaded OK"; - }, - plan => 1, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Load plugin (explicit path)', - switches => [ '-P', 'App::Prove::Plugin::Dummy', $dummy_test ], - args => { - argv => [qw( one two three )], - }, - expect => { - plugins => ['Dummy'], - }, - extra => sub { - my @loaded = get_import_log(); - is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], - "Plugin loaded OK"; - }, - plan => 1, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Load plugin (args + call load method)', - switches => [ '-P', 'Dummy2=fou,du,fafa', $dummy_test ], - args => { - argv => [qw( one two three )], - }, - expect => { - plugins => ['Dummy2'], - }, - extra => sub { - my @import = get_import_log(); - is_deeply \@import, - [ [ 'App::Prove::Plugin::Dummy2', 'fou', 'du', 'fafa' ] ], - "Plugin loaded OK"; - - my @loaded = get_plugin_load_log(); - is( scalar @loaded, 1, 'Plugin->load called OK' ); - my ( $plugin_class, $args ) = @{ shift @loaded }; - is( $plugin_class, 'App::Prove::Plugin::Dummy2', - 'plugin_class passed' - ); - isa_ok( - $args->{app_prove}, 'App::Prove', - 'app_prove object passed' - ); - is_deeply( - $args->{args}, [qw( fou du fafa )], - 'expected args passed' - ); - }, - plan => 5, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - { name => 'Load module', - switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ], - args => { - argv => [qw( one two three )], - }, - expect => { - plugins => ['Dummy'], - }, - extra => sub { - my @loaded = get_import_log(); - is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], - "Plugin loaded OK"; - }, - plan => 1, - runlog => [ - [ '_runtests', - { verbosity => 0, - show_count => 1, - }, - 'TAP::Harness', - $dummy_test - ] - ], - }, - - # TODO - # Hmm, that doesn't work... - # { name => 'Switch -h', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '-h', $dummy_test ], - # expect => {}, - # runlog => [ - # [ '_runtests', - # {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - - # { name => 'Switch --help', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '--help', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # { name => 'Switch -?', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '-?', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch -H', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '-H', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch --man', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '--man', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch -V', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '-V', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch --version', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '--version', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch --color!', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '--color!', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - { name => 'Switch -I=s@', - args => { - argv => [qw( one two three )], - }, - switches => [ '-Ilib', $dummy_test ], - expect => { - includes => sub { - my ( $val, $attr ) = @_; - return - 'ARRAY' eq ref $val - && 1 == @$val - && $val->[0] =~ /lib$/; - }, - }, - }, - - # { name => 'Switch -a', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '-a', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch --archive=-s', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '--archive=-s', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch --formatter=-s', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '--formatter=-s', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch -e', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '-e', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - # - # { name => 'Switch --harness=-s', - # args => { - # argv => [qw( one two three )], - # }, - # switches => [ '--harness=-s', $dummy_test ], - # expect => {}, - # runlog => [ - # [ {}, - # 'TAP::Harness', - # $dummy_test - # ] - # ], - # }, - - ); - - # END SCHEDULE - ######################################################################## - - my $extra_plan = 0; - for my $test (@SCHEDULE) { - $extra_plan += $test->{plan} || 0; - $extra_plan += 2 if $test->{runlog}; - $extra_plan += 1 if $test->{switches}; - } - - plan tests => @SCHEDULE * ( 3 + @ATTR ) + $extra_plan; -} # END PLAN - -# ACTUAL TEST -for my $test (@SCHEDULE) { - my $name = $test->{name}; - my $class = $test->{class} || 'FakeProve'; - - 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); - } - - unless ( - is_deeply $gotlog, $runlog, - "$name: run results match" - ) - { - use Data::Dumper; - diag Dumper( { wanted => $runlog, got => $gotlog } ); - } - } - } -} diff --git a/ext/Test-Harness/t/proveenv.t b/ext/Test-Harness/t/proveenv.t deleted file mode 100644 index be9942a043..0000000000 --- a/ext/Test-Harness/t/proveenv.t +++ /dev/null @@ -1,17 +0,0 @@ -#!perl -use strict; -use lib 't/lib'; -use Test::More tests => 2; -use App::Prove; - -{ - local $ENV{HARNESS_TIMER} = 0; - my $prv = App::Prove->new; - ok !$prv->timer, 'timer set via HARNESS_TIMER'; -} - -{ - local $ENV{HARNESS_TIMER} = 1; - my $prv = App::Prove->new; - ok $prv->timer, 'timer set via HARNESS_TIMER'; -} diff --git a/ext/Test-Harness/t/proverc.t b/ext/Test-Harness/t/proverc.t deleted file mode 100644 index 37d6de803b..0000000000 --- a/ext/Test-Harness/t/proverc.t +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -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'; - diff --git a/ext/Test-Harness/t/proverc/emptyexec b/ext/Test-Harness/t/proverc/emptyexec deleted file mode 100644 index 5381b8f015..0000000000 --- a/ext/Test-Harness/t/proverc/emptyexec +++ /dev/null @@ -1,2 +0,0 @@ ---exec '' - diff --git a/ext/Test-Harness/t/proverun.t b/ext/Test-Harness/t/proverun.t deleted file mode 100644 index 6e6c2f33f5..0000000000 --- a/ext/Test-Harness/t/proverun.t +++ /dev/null @@ -1,176 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; -use Test::More; -use File::Spec; -use App::Prove; - -my @SCHEDULE; - -BEGIN { - - # 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', - }, - ); - foreach my $test (@tests) { - - # let's fully expand that filename - $test->{file} = File::Spec->catfile( - 't', - 'sample-tests', - $test->{file} - ); - } - @SCHEDULE = ( - map { - { name => $_->{name}, - args => [ $_->{file} ], - expect => [ - [ 'new', - 'TAP::Parser::Iterator::Process', - { merge => undef, - command => [ - 'PERL', - $_->{file}, - ], - setup => \'CODE', - teardown => \'CODE', - - } - ] - ] - } - } @tests - ); - - plan tests => @SCHEDULE * 3; -} - -# Waaaaay too much boilerplate - -package FakeProve; -use vars qw( @ISA ); - -@ISA = 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 = (); - - local $^W; # no warnings - - my $orig_new = TAP::Parser::Iterator::Process->can('new'); - - # Avoid "used only once" warning - *TAP::Parser::Iterator::Process::new - = *TAP::Parser::Iterator::Process::new = sub { - push @call_log, [ 'new', @_ ]; - - # And then new turns round and tramples on our args... - $_[1] = { %{ $_[1] } }; - $orig_new->(@_); - }; - - # Patch TAP::Formatter::Console; - my $orig_output = \&TAP::Formatter::Console::_output; - *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} - # } - # ); -} - diff --git a/ext/Test-Harness/t/regression.t b/ext/Test-Harness/t/regression.t deleted file mode 100644 index 20879ca2b6..0000000000 --- a/ext/Test-Harness/t/regression.t +++ /dev/null @@ -1,3264 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - push @INC, 't/lib'; -} - -use strict; - -use Test::More 'no_plan'; - -use File::Spec; -use Config; - -use constant TRUE => "__TRUE__"; -use constant FALSE => "__FALSE__"; - -# if wait() is non-zero, we cannot reliably predict its value -use constant NOT_ZERO => "__NOT_ZERO__"; - -use TAP::Parser; - -my $IsVMS = $^O eq 'VMS'; -my $IsWin32 = $^O eq 'MSWin32'; - -my $SAMPLE_TESTS = File::Spec->catdir( - File::Spec->curdir, - 't', - 'sample-tests' -); - -my %deprecated = map { $_ => 1 } qw( - TAP::Parser::good_plan - TAP::Parser::Result::Plan::passed - TAP::Parser::Result::Test::passed - TAP::Parser::Result::Test::actual_passed - TAP::Parser::Result::passed -); -$SIG{__WARN__} = sub { - if ( $_[0] =~ /is deprecated/ ) { - my @caller = caller(1); - my $sub = $caller[3]; - ok exists $deprecated{$sub}, - "... we should get a deprecated warning for $sub"; - } - else { - CORE::warn @_; - } -}; - -# the %samples keys are the names of test scripts in t/sample-tests -my %samples = ( - descriptive => { - results => [ - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => "Interlock activated", - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "Megathrusters are go", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "Head formed", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "Blazing sword formed", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "Robeast destroyed", - is_unplanned => FALSE, - } - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - descriptive_trailing => { - results => [ - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => "Interlock activated", - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "Megathrusters are go", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "Head formed", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "Blazing sword formed", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "Robeast destroyed", - is_unplanned => FALSE, - }, - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - empty => { - results => [], - plan => '', - passed => [], - actual_passed => [], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - is_good_plan => FALSE, - tests_planned => undef, - tests_run => 0, - parse_errors => ['No plan found in TAP output'], - 'exit' => 0, - wait => 0, - version => 12, - }, - simple => { - results => [ - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - space_after_plan => { - results => [ - { is_plan => TRUE, - raw => '1..5 ', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - simple_yaml => { - results => [ - { is_version => TRUE, - raw => 'TAP version 13', - }, - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { is_yaml => TRUE, - data => [ - { 'fnurk' => 'skib', 'ponk' => 'gleeb' }, - { 'bar' => 'krup', 'foo' => 'plink' } - ], - raw => - " ---\n -\n fnurk: skib\n ponk: gleeb\n -\n bar: krup\n foo: plink\n ...", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { is_yaml => TRUE, - data => { - 'got' => [ '1', 'pong', '4' ], - 'expected' => [ '1', '2', '4' ] - }, - raw => - " ---\n expected:\n - 1\n - 2\n - 4\n got:\n - 1\n - pong\n - 4\n ...", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 13, - }, - simple_fail => { - results => [ - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1, 3, 4 ], - actual_passed => [ 1, 3, 4 ], - failed => [ 2, 5 ], - actual_failed => [ 2, 5 ], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - skip => { - results => [ - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => TRUE, - has_todo => FALSE, - number => 2, - description => "", - explanation => 'rain delay', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [2], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - skip_nomsg => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..1', - tests_planned => 1, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => TRUE, - has_todo => FALSE, - number => 1, - description => "", - explanation => '', - }, - ], - plan => '1..1', - passed => [1], - actual_passed => [1], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [1], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 1, - tests_run => TRUE, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - todo_inline => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..3', - tests_planned => 3, - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => TRUE, - number => 1, - description => "- Foo", - explanation => 'Just testing the todo interface.', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => TRUE, - number => 2, - description => "- Unexpected success", - explanation => 'Just testing the todo interface.', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "- This is not todo", - explanation => '', - }, - ], - plan => '1..3', - passed => [ 1, 2, 3 ], - actual_passed => [ 2, 3 ], - failed => [], - actual_failed => [1], - todo => [ 1, 2 ], - todo_passed => [2], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 3, - tests_run => 3, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - todo => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..5 todo 3 2;', - tests_planned => 5, - todo_list => [ 3, 2 ], - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => TRUE, - number => 2, - description => "", - explanation => '', - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => TRUE, - number => 3, - description => "", - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - explanation => '', - }, - ], - plan => '1..5', - passed => [ 1, 2, 3, 4, 5 ], - actual_passed => [ 1, 2, 4, 5 ], - failed => [], - actual_failed => [3], - todo => [ 2, 3 ], - todo_passed => [2], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - duplicates => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..10', - tests_planned => 10, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 6, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 7, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 8, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 9, - description => '', - explanation => '', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 10, - description => '', - explanation => '', - is_unplanned => TRUE, - }, - ], - plan => '1..10', - passed => [ 1 .. 4, 4 .. 9 ], - actual_passed => [ 1 .. 4, 4 .. 10 ], - failed => [10], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - tests_planned => 10, - tests_run => 11, - parse_errors => [ - 'Tests out of sequence. Found (4) but expected (5)', - 'Tests out of sequence. Found (5) but expected (6)', - 'Tests out of sequence. Found (6) but expected (7)', - 'Tests out of sequence. Found (7) but expected (8)', - 'Tests out of sequence. Found (8) but expected (9)', - 'Tests out of sequence. Found (9) but expected (10)', - 'Tests out of sequence. Found (10) but expected (11)', - 'Bad plan. You planned 10 tests but ran 11.', - ], - 'exit' => 0, - wait => 0, - }, - no_nums => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..5', - tests_planned => 5, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => "", - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - } - ], - plan => '1..5', - passed => [ 1, 2, 4, 5 ], - actual_passed => [ 1, 2, 4, 5 ], - failed => [3], - actual_failed => [3], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - bailout => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..5', - tests_planned => 5, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => "", - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { is_bailout => TRUE, - explanation => "GERONIMMMOOOOOO!!!", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - } - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - no_output => { - results => [], - plan => '', - passed => [], - actual_passed => [], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - tests_planned => undef, - tests_run => 0, - parse_errors => [ 'No plan found in TAP output', ], - 'exit' => 0, - wait => 0, - }, - too_many => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..3', - tests_planned => 3, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => "", - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - is_unplanned => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - is_unplanned => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 6, - description => "", - is_unplanned => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 7, - description => "", - is_unplanned => TRUE, - }, - ], - plan => '1..3', - passed => [ 1 .. 3 ], - actual_passed => [ 1 .. 7 ], - failed => [ 4 .. 7 ], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - tests_planned => 3, - tests_run => 7, - parse_errors => ['Bad plan. You planned 3 tests but ran 7.'], - 'exit' => 4, - wait => NOT_ZERO, - skip_if => sub {$IsVMS}, - }, - taint => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..1', - tests_planned => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => "- -T honored", - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - }, - ], - plan => '1..1', - passed => [ 1 .. 1 ], - actual_passed => [ 1 .. 1 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => TRUE, - tests_run => TRUE, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - 'die' => { - results => [], - plan => '', - passed => [], - actual_passed => [], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - tests_planned => undef, - tests_run => 0, - parse_errors => [ 'No plan found in TAP output', ], - 'exit' => NOT_ZERO, - wait => NOT_ZERO, - }, - die_head_end => { - results => [ - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - }, - ], - plan => '', - passed => [ 1 .. 4 ], - actual_passed => [ 1 .. 4 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - tests_planned => undef, - tests_run => 4, - parse_errors => [ 'No plan found in TAP output', ], - 'exit' => NOT_ZERO, - wait => NOT_ZERO, - }, - die_last_minute => { - results => [ - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - }, - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..4', - tests_planned => 4, - }, - ], - plan => '1..4', - passed => [ 1 .. 4 ], - actual_passed => [ 1 .. 4 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 4, - tests_run => 4, - parse_errors => [], - 'exit' => NOT_ZERO, - wait => NOT_ZERO, - }, - bignum => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..2', - tests_planned => 2, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 136211425, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 136211426, - description => '', - explanation => '', - }, - ], - plan => '1..2', - passed => [ 1, 2 ], - actual_passed => [ 1, 2, 136211425, 136211426 ], - failed => [ 136211425, 136211426 ], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - tests_planned => 2, - tests_run => 4, - parse_errors => [ - 'Tests out of sequence. Found (136211425) but expected (3)', - 'Tests out of sequence. Found (136211426) but expected (4)', - 'Bad plan. You planned 2 tests but ran 4.' - ], - 'exit' => 0, - wait => 0, - }, - bignum_many => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..2', - tests_planned => 2, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 99997, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 99998, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 99999, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 100000, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 100001, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 100002, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 100003, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 100004, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 100005, - description => '', - explanation => '', - }, - ], - plan => '1..2', - passed => [ 1, 2 ], - actual_passed => [ 1, 2, 99997 .. 100005 ], - failed => [ 99997 .. 100005 ], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - tests_planned => 2, - tests_run => 11, - parse_errors => [ - 'Tests out of sequence. Found (99997) but expected (3)', - 'Tests out of sequence. Found (99998) but expected (4)', - 'Tests out of sequence. Found (99999) but expected (5)', - 'Tests out of sequence. Found (100000) but expected (6)', - 'Tests out of sequence. Found (100001) but expected (7)', - 'Tests out of sequence. Found (100002) but expected (8)', - 'Tests out of sequence. Found (100003) but expected (9)', - 'Tests out of sequence. Found (100004) but expected (10)', - 'Tests out of sequence. Found (100005) but expected (11)', - 'Bad plan. You planned 2 tests but ran 11.' - ], - 'exit' => 0, - wait => 0, - }, - combined => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..10', - tests_planned => 10, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => 'basset hounds got long ears', - explanation => '', - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => 'all hell broke loose', - explanation => '', - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => TRUE, - number => 4, - description => '', - explanation => 'if I heard a voice from heaven ...', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => 'say "live without loving",', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 6, - description => "I'd beg off.", - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => '1', - has_todo => FALSE, - number => 7, - description => '', - explanation => 'contract negotiations', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 8, - description => 'Girls are such exquisite hell', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => TRUE, - number => 9, - description => 'Elegy 9B', - explanation => '', - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 10, - description => '', - explanation => '', - }, - ], - plan => '1..10', - passed => [ 1 .. 2, 4 .. 9 ], - actual_passed => [ 1 .. 2, 5 .. 9 ], - failed => [ 3, 10 ], - actual_failed => [ 3, 4, 10 ], - todo => [ 4, 9 ], - todo_passed => [9], - skipped => [7], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 10, - tests_run => 10, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - head_end => { - results => [ - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comments', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comment', - }, - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..4', - tests_planned => 4, - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'more ignored stuff', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'and yet more', - }, - ], - plan => '1..4', - passed => [ 1 .. 4 ], - actual_passed => [ 1 .. 4 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 4, - tests_run => 4, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - head_fail => { - results => [ - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comments', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comment', - }, - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..4', - tests_planned => 4, - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'more ignored stuff', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'and yet more', - }, - ], - plan => '1..4', - passed => [ 1, 3, 4 ], - actual_passed => [ 1, 3, 4 ], - failed => [2], - actual_failed => [2], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 4, - tests_run => 4, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - out_of_order => { - results => [ - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '- Test that argument passing works', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => - '- Test that passing arguments as references work', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '- Test a normal sub', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 6, - description => '- Detach test', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 8, - description => '- Nested thread test', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 9, - description => '- Nested thread test', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 10, - description => '- Wanted 7, got 7', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 11, - description => '- Wanted 7, got 7', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 12, - description => '- Wanted 8, got 8', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 13, - description => '- Wanted 8, got 8', - explanation => '', - }, - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..15', - tests_planned => 15, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => '- Check that Config::threads is true', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 7, - description => '- Detach test', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 14, - description => - '- Check so that tid for threads work for main thread', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 15, - description => - '- Check so that tid for threads work for main thread', - explanation => '', - }, - ], - plan => '1..15', - passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], - actual_passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - is_good_plan => FALSE, - tests_planned => 15, - tests_run => 15, - - # Note that tests 14 and 15 *are* in the correct sequence. - parse_errors => [ - 'Tests out of sequence. Found (2) but expected (1)', - 'Tests out of sequence. Found (3) but expected (2)', - 'Tests out of sequence. Found (4) but expected (3)', - 'Tests out of sequence. Found (6) but expected (4)', - 'Tests out of sequence. Found (8) but expected (5)', - 'Tests out of sequence. Found (9) but expected (6)', - 'Tests out of sequence. Found (10) but expected (7)', - 'Tests out of sequence. Found (11) but expected (8)', - 'Tests out of sequence. Found (12) but expected (9)', - 'Tests out of sequence. Found (13) but expected (10)', - 'Plan (1..15) must be at the beginning or end of the TAP output', - 'Tests out of sequence. Found (1) but expected (11)', - 'Tests out of sequence. Found (5) but expected (12)', - 'Tests out of sequence. Found (7) but expected (13)', - ], - 'exit' => 0, - wait => 0, - }, - skipall => { - results => [ - { is_plan => TRUE, - raw => '1..0 # skipping: rope', - tests_planned => 0, - passed => TRUE, - is_ok => TRUE, - directive => 'SKIP', - explanation => 'rope' - }, - ], - plan => '1..0', - passed => [], - actual_passed => [], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 0, - tests_run => 0, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - skip_all => 'rope', - }, - skipall_v13 => { - results => [ - { is_version => TRUE, - raw => 'TAP version 13', - }, - { is_unknown => TRUE, - raw => '1..0 # skipping: rope', - }, - ], - plan => '', - passed => [], - actual_passed => [], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => FALSE, - is_good_plan => FALSE, - tests_planned => FALSE, - tests_run => 0, - parse_errors => ['No plan found in TAP output'], - 'exit' => 0, - wait => 0, - version => 13, - }, - strict => { - results => [ - { is_version => TRUE, - raw => 'TAP version 13', - }, - { is_plan => TRUE, - raw => '1..1', - }, - { is_pragma => TRUE, - raw => 'pragma +strict', - pragmas => ['+strict'], - }, - { is_unknown => TRUE, raw => 'Nonsense!', - }, - { is_pragma => TRUE, - raw => 'pragma -strict', - pragmas => ['-strict'], - }, - { is_unknown => TRUE, - raw => "Doesn't matter.", - }, - { is_test => TRUE, - raw => 'ok 1 All OK', - } - ], - plan => '1..1', - passed => [1], - actual_passed => [1], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 1, - tests_run => 1, - parse_errors => ['Unknown TAP token: "Nonsense!"'], - 'exit' => 0, # TODO: Is this right??? - wait => 0, - version => 13, - }, - skipall_nomsg => { - results => [ - { is_plan => TRUE, - raw => '1..0', - tests_planned => 0, - passed => TRUE, - is_ok => TRUE, - directive => 'SKIP', - explanation => '' - }, - ], - plan => '1..0', - passed => [], - actual_passed => [], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 0, - tests_run => 0, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - skip_all => '(no reason given)', - }, - todo_misparse => { - results => [ - { is_plan => TRUE, - raw => '1..1', - tests_planned => TRUE, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => FALSE, - is_actual_ok => FALSE, - passed => FALSE, - is_ok => FALSE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => 'Hamlette # TODOORNOTTODO', - explanation => '', - }, - ], - plan => '1..1', - passed => [], - actual_passed => [], - failed => [1], - actual_failed => [1], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => TRUE, - tests_run => 1, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - shbang_misparse => { - results => [ - { is_plan => TRUE, - raw => '1..2', - tests_planned => 2, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => "", - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - ], - plan => '1..2', - passed => [ 1 .. 2 ], - actual_passed => [ 1 .. 2 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 2, - tests_run => 2, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - switches => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..1', - tests_planned => 1, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - explanation => '', - }, - ], - __ARGS__ => { switches => ['-Mstrict'] }, - plan => '1..1', - passed => [1], - actual_passed => [1], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 1, - tests_run => TRUE, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - inc_taint => { - results => [ - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..1', - tests_planned => 1, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - explanation => '', - }, - ], - __ARGS__ => { switches => ['-Iexamples'] }, - plan => '1..1', - passed => [1], - actual_passed => [1], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 1, - tests_run => TRUE, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - sequence_misparse => { - results => [ - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "\# skipped on foobar system", - }, - { is_comment => TRUE, - comment => '1234567890123456789012345678901234567890', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { is_comment => TRUE, - comment => '1234567890123456789012345678901234567890', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - - # For some reason mixing stdout with stderr is unreliable on Windows - ( $IsWin32 - ? () - : ( stdout_stderr => { - results => [ - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comments', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => '', - explanation => '', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comment', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'more ignored stuff', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'and yet more', - }, - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..4', - tests_planned => 4, - }, - ], - plan => '1..4', - passed => [ 1 .. 4 ], - actual_passed => [ 1 .. 4 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 4, - tests_run => 4, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - need_open3 => 1, - } - ) - ), - - junk_before_plan => { - results => [ - { is_unknown => TRUE, - raw => 'this is junk', - }, - { is_comment => TRUE, - comment => "this is a comment", - }, - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..1', - tests_planned => 1, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - }, - ], - plan => '1..1', - passed => [ 1 .. 1 ], - actual_passed => [ 1 .. 1 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 1, - tests_run => 1, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - version_good => { - results => [ - { is_version => TRUE, - raw => 'TAP version 13', - }, - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 13, - }, - version_old => { - results => [ - { is_version => TRUE, - raw => 'TAP version 12', - }, - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => - ['Explicit TAP version must be at least 13. Got version 12'], - 'exit' => 0, - wait => 0, - version => 12, - }, - version_late => { - results => [ - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { is_version => TRUE, - raw => 'TAP version 13', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => "", - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - description => "", - }, - ], - plan => '1..5', - passed => [ 1 .. 5 ], - actual_passed => [ 1 .. 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => - ['If TAP version is present it must be the first line of output'], - 'exit' => 0, - wait => 0, - version => 12, - }, - - escape_eol => { - results => [ - { is_plan => TRUE, - raw => '1..2', - tests_planned => 2, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => - 'Should parse as literal backslash --> \\', - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => 'Not a continuation line', - is_unplanned => FALSE, - }, - ], - plan => '1..2', - passed => [ 1 .. 2 ], - actual_passed => [ 1 .. 2 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 2, - tests_run => 2, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - - escape_hash => { - results => [ - { is_plan => TRUE, - raw => '1..3', - tests_planned => 3, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => 'Not a \\# TODO', - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => 'Not a \\# SKIP', - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => 'Escaped \\\\\\#', - is_unplanned => FALSE, - }, - ], - plan => '1..3', - passed => [ 1 .. 3 ], - actual_passed => [ 1 .. 3 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 3, - tests_run => 3, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - }, - - zero_valid => { - results => [ - { is_plan => TRUE, - raw => '1..5', - tests_planned => 5, - passed => TRUE, - is_ok => TRUE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => '- One', - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => '- Two', - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => '- Three', - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => '- Four', - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 0, - is_unplanned => FALSE, - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - description => '- Five', - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 5, - is_unplanned => FALSE, - }, - ], - plan => '1..5', - passed => [ 1 .. 3, 0, 5 ], - actual_passed => [ 1 .. 3, 0, 5 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 5, - tests_run => 5, - parse_errors => [ - 'Tests out of sequence. Found (0) but expected (4)', - ], - 'exit' => 0, - wait => 0, - version => 12, - }, -); - -my %HANDLER_FOR = ( - NOT_ZERO, sub { local $^W; 0 != shift }, - TRUE, sub { local $^W; !!shift }, - FALSE, sub { local $^W; !shift }, -); - -my $can_open3 = ( $Config{d_fork} || $IsWin32 ) ? 1 : 0; - -for my $hide_fork ( 0 .. $can_open3 ) { - if ($hide_fork) { - no strict 'refs'; - local $^W = 0; - *{'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 ) { - local $^W; # uninit warnings - - $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/#/<hash>/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 diff --git a/ext/Test-Harness/t/results.t b/ext/Test-Harness/t/results.t deleted file mode 100644 index 0522dd6299..0000000000 --- a/ext/Test-Harness/t/results.t +++ /dev/null @@ -1,295 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -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 vars qw($VERSION @ISA); - @ISA = 'TAP::Parser::Result'; - TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); -} - -{ - my $r = eval { $factory->make_result( { type => 'my_type' } ) }; - my $error = $@; - isa_ok( $r, 'MyResult', 'register custom type' ); - ok( !$error, '... and no error' ); -} - -# -# test unknown tokens -# - -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"; - } -} diff --git a/ext/Test-Harness/t/sample-tests/bailout b/ext/Test-Harness/t/sample-tests/bailout deleted file mode 100644 index b25f417b52..0000000000 --- a/ext/Test-Harness/t/sample-tests/bailout +++ /dev/null @@ -1,11 +0,0 @@ -# Sleep makes Mac OS open3 race problem more repeatable -sleep 1; -print <<DUMMY_TEST; -1..5 -ok 1 -ok 2 -ok 3 -Bail out! GERONIMMMOOOOOO!!! -ok 4 -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/bignum b/ext/Test-Harness/t/sample-tests/bignum deleted file mode 100644 index b5824a12a1..0000000000 --- a/ext/Test-Harness/t/sample-tests/bignum +++ /dev/null @@ -1,7 +0,0 @@ -print <<DUMMY; -1..2 -ok 1 -ok 2 -ok 136211425 -ok 136211426 -DUMMY diff --git a/ext/Test-Harness/t/sample-tests/bignum_many b/ext/Test-Harness/t/sample-tests/bignum_many deleted file mode 100644 index 1e30b2f1dd..0000000000 --- a/ext/Test-Harness/t/sample-tests/bignum_many +++ /dev/null @@ -1,14 +0,0 @@ -print <<DUMMY; -1..2 -ok 1 -ok 2 -ok 99997 -ok 99998 -ok 99999 -ok 100000 -ok 100001 -ok 100002 -ok 100003 -ok 100004 -ok 100005 -DUMMY diff --git a/ext/Test-Harness/t/sample-tests/combined b/ext/Test-Harness/t/sample-tests/combined deleted file mode 100644 index 7e157092b3..0000000000 --- a/ext/Test-Harness/t/sample-tests/combined +++ /dev/null @@ -1,13 +0,0 @@ -print <<DUMMY_TEST; -1..10 -ok 1 -ok 2 basset hounds got long ears -not ok 3 all hell broke loose -not ok 4 # TODO if I heard a voice from heaven ... -ok say "live without loving", -ok 6 I'd beg off. -ok 7 # Skip contract negotiations -ok 8 Girls are such exquisite hell -ok 9 Elegy 9B # TOdO -not ok 10 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/combined_compat b/ext/Test-Harness/t/sample-tests/combined_compat deleted file mode 100644 index 8dfaa28e92..0000000000 --- a/ext/Test-Harness/t/sample-tests/combined_compat +++ /dev/null @@ -1,13 +0,0 @@ -print <<DUMMY_TEST; -1..10 todo 4 10 -ok 1 -ok 2 basset hounds got long ears -not ok 3 all hell broke lose -ok 4 -ok -ok 6 -ok 7 # Skip contract negociations -ok 8 -not ok 9 -not ok 10 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/delayed b/ext/Test-Harness/t/sample-tests/delayed deleted file mode 100644 index 1f24ef6790..0000000000 --- a/ext/Test-Harness/t/sample-tests/delayed +++ /dev/null @@ -1,26 +0,0 @@ -# Used to test Process.pm -use Time::HiRes qw(sleep); - -my $delay = 0.01; - -$| = 1; - -my @parts = ( - "1.", - ".5\n", - "ok 1 00000\n", - "ok 2\nnot", - " ok 3", - "\nok 4\nok ", - "5 00000", - "" -); - -my $delay_at = shift || 0; - -while (@parts) { - sleep $delay if ( $delay_at & 1 ); - $delay_at >>= 1; - print shift @parts; -} -sleep $delay if ( $delay_at & 1 ); diff --git a/ext/Test-Harness/t/sample-tests/descriptive b/ext/Test-Harness/t/sample-tests/descriptive deleted file mode 100644 index e165ac1bf5..0000000000 --- a/ext/Test-Harness/t/sample-tests/descriptive +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY_TEST; -1..5 -ok 1 Interlock activated -ok 2 Megathrusters are go -ok 3 Head formed -ok 4 Blazing sword formed -ok 5 Robeast destroyed -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/descriptive_trailing b/ext/Test-Harness/t/sample-tests/descriptive_trailing deleted file mode 100644 index f92d7ca694..0000000000 --- a/ext/Test-Harness/t/sample-tests/descriptive_trailing +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY_TEST; -ok 1 Interlock activated -ok 2 Megathrusters are go -ok 3 Head formed -ok 4 Blazing sword formed -ok 5 Robeast destroyed -1..5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/die b/ext/Test-Harness/t/sample-tests/die deleted file mode 100644 index ca8b0a9b0b..0000000000 --- a/ext/Test-Harness/t/sample-tests/die +++ /dev/null @@ -1,2 +0,0 @@ -eval "use vmsish 'hushed'" if ($^O eq 'VMS'); -exit 1; # exit because die() can be noisy diff --git a/ext/Test-Harness/t/sample-tests/die_head_end b/ext/Test-Harness/t/sample-tests/die_head_end deleted file mode 100644 index 494e4d3c82..0000000000 --- a/ext/Test-Harness/t/sample-tests/die_head_end +++ /dev/null @@ -1,9 +0,0 @@ -print <<DUMMY_TEST; -ok 1 -ok 2 -ok 3 -ok 4 -DUMMY_TEST - -eval "use vmsish 'hushed'" if ($^O eq 'VMS'); -exit 1; diff --git a/ext/Test-Harness/t/sample-tests/die_last_minute b/ext/Test-Harness/t/sample-tests/die_last_minute deleted file mode 100644 index ea533d628e..0000000000 --- a/ext/Test-Harness/t/sample-tests/die_last_minute +++ /dev/null @@ -1,10 +0,0 @@ -print <<DUMMY_TEST; -ok 1 -ok 2 -ok 3 -ok 4 -1..4 -DUMMY_TEST - -eval "use vmsish 'hushed'" if ($^O eq 'VMS'); -exit 1; diff --git a/ext/Test-Harness/t/sample-tests/die_unfinished b/ext/Test-Harness/t/sample-tests/die_unfinished deleted file mode 100644 index 3efd08ff09..0000000000 --- a/ext/Test-Harness/t/sample-tests/die_unfinished +++ /dev/null @@ -1,9 +0,0 @@ -print <<DUMMY_TEST; -1..4 -ok 1 -ok 2 -ok 3 -DUMMY_TEST - -eval "use vmsish 'hushed'" if ($^O eq 'VMS'); -exit 1; diff --git a/ext/Test-Harness/t/sample-tests/duplicates b/ext/Test-Harness/t/sample-tests/duplicates deleted file mode 100644 index 63f6a706b6..0000000000 --- a/ext/Test-Harness/t/sample-tests/duplicates +++ /dev/null @@ -1,14 +0,0 @@ -print <<DUMMY_TEST -1..10 -ok 1 -ok 2 -ok 3 -ok 4 -ok 4 -ok 5 -ok 6 -ok 7 -ok 8 -ok 9 -ok 10 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/echo b/ext/Test-Harness/t/sample-tests/echo deleted file mode 100644 index 6696e71f17..0000000000 --- a/ext/Test-Harness/t/sample-tests/echo +++ /dev/null @@ -1,2 +0,0 @@ -print '1..', scalar(@ARGV), "\n"; -print "ok $_ ", $ARGV[ $_ - 1 ], "\n" for 1 .. @ARGV; diff --git a/ext/Test-Harness/t/sample-tests/empty b/ext/Test-Harness/t/sample-tests/empty deleted file mode 100644 index 66d42ad402..0000000000 --- a/ext/Test-Harness/t/sample-tests/empty +++ /dev/null @@ -1,2 +0,0 @@ -__END__ -Used to exercise the "empty test" case. diff --git a/ext/Test-Harness/t/sample-tests/escape_eol b/ext/Test-Harness/t/sample-tests/escape_eol deleted file mode 100644 index 1b8ba27f1e..0000000000 --- a/ext/Test-Harness/t/sample-tests/escape_eol +++ /dev/null @@ -1,5 +0,0 @@ -print <<DUMMY_TEST; -1..2 -ok 1 Should parse as literal backslash --> \\ -ok 2 Not a continuation line -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/escape_hash b/ext/Test-Harness/t/sample-tests/escape_hash deleted file mode 100644 index c404372c0c..0000000000 --- a/ext/Test-Harness/t/sample-tests/escape_hash +++ /dev/null @@ -1,6 +0,0 @@ -print <<DUMMY_TEST; -1..3 -ok 1 Not a \\# TODO -ok 2 Not a \\# SKIP -ok 3 Escaped \\\\\\# -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/head_end b/ext/Test-Harness/t/sample-tests/head_end deleted file mode 100644 index 14a32f2fe6..0000000000 --- a/ext/Test-Harness/t/sample-tests/head_end +++ /dev/null @@ -1,11 +0,0 @@ -print <<DUMMY_TEST; -# comments -ok 1 -ok 2 -ok 3 -ok 4 -# comment -1..4 -# more ignored stuff -# and yet more -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/head_fail b/ext/Test-Harness/t/sample-tests/head_fail deleted file mode 100644 index 9d1667ab19..0000000000 --- a/ext/Test-Harness/t/sample-tests/head_fail +++ /dev/null @@ -1,11 +0,0 @@ -print <<DUMMY_TEST; -# comments -ok 1 -not ok 2 -ok 3 -ok 4 -# comment -1..4 -# more ignored stuff -# and yet more -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/inc_taint b/ext/Test-Harness/t/sample-tests/inc_taint deleted file mode 100644 index d1be66706c..0000000000 --- a/ext/Test-Harness/t/sample-tests/inc_taint +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/perl -Tw - -use Test::More tests => 1; - -ok( grep( /examples/, @INC ) ); - diff --git a/ext/Test-Harness/t/sample-tests/junk_before_plan b/ext/Test-Harness/t/sample-tests/junk_before_plan deleted file mode 100644 index b2ad018301..0000000000 --- a/ext/Test-Harness/t/sample-tests/junk_before_plan +++ /dev/null @@ -1,6 +0,0 @@ -print <<DUMMY_TEST; -this is junk -# this is a comment -1..1 -ok 1 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/lone_not_bug b/ext/Test-Harness/t/sample-tests/lone_not_bug deleted file mode 100644 index 10eaa2a3b0..0000000000 --- a/ext/Test-Harness/t/sample-tests/lone_not_bug +++ /dev/null @@ -1,9 +0,0 @@ -# There was a bug where the first test would be considered a -# 'lone not' failure. -print <<DUMMY; -ok 1 -ok 2 -ok 3 -ok 4 -1..4 -DUMMY diff --git a/ext/Test-Harness/t/sample-tests/no_nums b/ext/Test-Harness/t/sample-tests/no_nums deleted file mode 100644 index c32d3f22ba..0000000000 --- a/ext/Test-Harness/t/sample-tests/no_nums +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY_TEST; -1..5 -ok -ok -not ok -ok -ok -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/no_output b/ext/Test-Harness/t/sample-tests/no_output deleted file mode 100644 index 505acda7e6..0000000000 --- a/ext/Test-Harness/t/sample-tests/no_output +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/perl -w - -exit; diff --git a/ext/Test-Harness/t/sample-tests/out_err_mix b/ext/Test-Harness/t/sample-tests/out_err_mix deleted file mode 100644 index c802eb4a11..0000000000 --- a/ext/Test-Harness/t/sample-tests/out_err_mix +++ /dev/null @@ -1,13 +0,0 @@ -sub _autoflush { - my $flushed = shift; - my $old_fh = select $flushed; - $| = 1; - select $old_fh; -} - -_autoflush( \*STDOUT ); -_autoflush( \*STDERR ); - -print STDOUT "one\n"; -print STDERR "two\n\n"; -print STDOUT "three\n"; diff --git a/ext/Test-Harness/t/sample-tests/out_of_order b/ext/Test-Harness/t/sample-tests/out_of_order deleted file mode 100644 index 77641aa362..0000000000 --- a/ext/Test-Harness/t/sample-tests/out_of_order +++ /dev/null @@ -1,22 +0,0 @@ -# From a bungled core thread test. -# -# The important thing here is that the last test is the right test. -# Test::Harness would misparse this as being a valid test. -print <<DUMMY; -ok 2 - Test that argument passing works -ok 3 - Test that passing arguments as references work -ok 4 - Test a normal sub -ok 6 - Detach test -ok 8 - Nested thread test -ok 9 - Nested thread test -ok 10 - Wanted 7, got 7 -ok 11 - Wanted 7, got 7 -ok 12 - Wanted 8, got 8 -ok 13 - Wanted 8, got 8 -1..15 -ok 1 -ok 5 - Check that Config::threads is true -ok 7 - Detach test -ok 14 - Check so that tid for threads work for main thread -ok 15 - Check so that tid for threads work for main thread -DUMMY diff --git a/ext/Test-Harness/t/sample-tests/schwern b/ext/Test-Harness/t/sample-tests/schwern deleted file mode 100644 index d45726bc7a..0000000000 --- a/ext/Test-Harness/t/sample-tests/schwern +++ /dev/null @@ -1,3 +0,0 @@ -use Test::More; -plan tests => 1; -ok 23, 42; diff --git a/ext/Test-Harness/t/sample-tests/schwern-todo-quiet b/ext/Test-Harness/t/sample-tests/schwern-todo-quiet deleted file mode 100644 index 4d482d43fa..0000000000 --- a/ext/Test-Harness/t/sample-tests/schwern-todo-quiet +++ /dev/null @@ -1,13 +0,0 @@ -print <<DUMMY_TEST; -1..3 -ok 1 -not ok 2 -# Failed test at ../../andy/schwern.pl line 17. -# got: '23' -# expected: '42' -not ok 3 # TODO Roman numerials still not a built in type -# Failed (TODO) test at ../../andy/schwern.pl line 20. -# got: 'XXIII' -# expected: '23' -# Looks like you failed 1 test of 3. -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/segfault b/ext/Test-Harness/t/sample-tests/segfault deleted file mode 100644 index c5670a42b5..0000000000 --- a/ext/Test-Harness/t/sample-tests/segfault +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/perl - -print "1..1\n"; -print "ok 1\n"; -kill 11, $$; diff --git a/ext/Test-Harness/t/sample-tests/sequence_misparse b/ext/Test-Harness/t/sample-tests/sequence_misparse deleted file mode 100644 index c66d127bb0..0000000000 --- a/ext/Test-Harness/t/sample-tests/sequence_misparse +++ /dev/null @@ -1,14 +0,0 @@ -# -# This was causing parse failures due to an error in the TAP specification. -# Hash marks *are* allowed in the description. -# -print <<DUMMY; -1..5 -ok 1 -ok 2 -ok 3 # skipped on foobar system -# 1234567890123456789012345678901234567890 -ok 4 -# 1234567890123456789012345678901234567890 -ok 5 -DUMMY diff --git a/ext/Test-Harness/t/sample-tests/shbang_misparse b/ext/Test-Harness/t/sample-tests/shbang_misparse deleted file mode 100644 index ab93b468ae..0000000000 --- a/ext/Test-Harness/t/sample-tests/shbang_misparse +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/perl-latest - -# The above #! line was misparsed as having a -t. -# Pre-5.8 this will simply cause perl to choke, since there was no -t. -# Post-5.8 taint warnings will mistakenly be on. - -print "1..2\n"; -print "ok 1\n"; -my $warning = ''; -$SIG{__WARN__} = sub { $warning .= $_[0] }; -eval( "#" . substr( $0, 0, 0 ) ); -print $warning ? "not ok 2\n" : "ok 2\n"; diff --git a/ext/Test-Harness/t/sample-tests/simple b/ext/Test-Harness/t/sample-tests/simple deleted file mode 100644 index d6b85846b2..0000000000 --- a/ext/Test-Harness/t/sample-tests/simple +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY_TEST; -1..5 -ok 1 -ok 2 -ok 3 -ok 4 -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/simple_fail b/ext/Test-Harness/t/sample-tests/simple_fail deleted file mode 100644 index aa65f5f66d..0000000000 --- a/ext/Test-Harness/t/sample-tests/simple_fail +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY_TEST; -1..5 -ok 1 -not ok 2 -ok 3 -ok 4 -not ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/simple_yaml b/ext/Test-Harness/t/sample-tests/simple_yaml deleted file mode 100644 index 9f52c5c8a8..0000000000 --- a/ext/Test-Harness/t/sample-tests/simple_yaml +++ /dev/null @@ -1,27 +0,0 @@ -print <<DUMMY_TEST; -TAP version 13 -1..5 -ok 1 -ok 2 - --- - - - fnurk: skib - ponk: gleeb - - - bar: krup - foo: plink - ... -ok 3 -ok 4 - --- - expected: - - 1 - - 2 - - 4 - got: - - 1 - - pong - - 4 - ... -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/skip b/ext/Test-Harness/t/sample-tests/skip deleted file mode 100644 index 6a9cd662bc..0000000000 --- a/ext/Test-Harness/t/sample-tests/skip +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY_TEST; -1..5 -ok 1 -ok 2 # skip rain delay -ok 3 -ok 4 -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/skip_nomsg b/ext/Test-Harness/t/sample-tests/skip_nomsg deleted file mode 100644 index 51d1ed6b43..0000000000 --- a/ext/Test-Harness/t/sample-tests/skip_nomsg +++ /dev/null @@ -1,4 +0,0 @@ -print <<DUMMY; -1..1 -ok 1 # Skip -DUMMY diff --git a/ext/Test-Harness/t/sample-tests/skipall b/ext/Test-Harness/t/sample-tests/skipall deleted file mode 100644 index ceb2c19b3a..0000000000 --- a/ext/Test-Harness/t/sample-tests/skipall +++ /dev/null @@ -1,3 +0,0 @@ -print <<DUMMY_TEST; -1..0 # skipping: rope -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/skipall_nomsg b/ext/Test-Harness/t/sample-tests/skipall_nomsg deleted file mode 100644 index 9b0dc11a69..0000000000 --- a/ext/Test-Harness/t/sample-tests/skipall_nomsg +++ /dev/null @@ -1,2 +0,0 @@ -print "1..0\n"; -exit 0; diff --git a/ext/Test-Harness/t/sample-tests/skipall_v13 b/ext/Test-Harness/t/sample-tests/skipall_v13 deleted file mode 100644 index d16bd4f652..0000000000 --- a/ext/Test-Harness/t/sample-tests/skipall_v13 +++ /dev/null @@ -1,4 +0,0 @@ -print <<DUMMY_TEST; -TAP version 13 -1..0 # skipping: rope -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/space_after_plan b/ext/Test-Harness/t/sample-tests/space_after_plan deleted file mode 100644 index d454c20d4d..0000000000 --- a/ext/Test-Harness/t/sample-tests/space_after_plan +++ /dev/null @@ -1,3 +0,0 @@ -# gforth TAP generates a space after the plan. Should probably be allowed. -print "1..5 \n"; -print "ok $_ \n" for 1..5; diff --git a/ext/Test-Harness/t/sample-tests/stdout_stderr b/ext/Test-Harness/t/sample-tests/stdout_stderr deleted file mode 100644 index ce17484d65..0000000000 --- a/ext/Test-Harness/t/sample-tests/stdout_stderr +++ /dev/null @@ -1,9 +0,0 @@ -use Test::More 'no_plan'; -diag 'comments'; -ok 1; -ok 1; -ok 1; -diag 'comment'; -ok 1; -diag 'more ignored stuff'; -diag 'and yet more'; diff --git a/ext/Test-Harness/t/sample-tests/strict b/ext/Test-Harness/t/sample-tests/strict deleted file mode 100644 index b89138de40..0000000000 --- a/ext/Test-Harness/t/sample-tests/strict +++ /dev/null @@ -1,9 +0,0 @@ -print <<DUMMY_TEST; -TAP version 13 -1..1 -pragma +strict -Nonsense! -pragma -strict -Doesn't matter. -ok 1 All OK -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/switches b/ext/Test-Harness/t/sample-tests/switches deleted file mode 100644 index 8ce9c9a589..0000000000 --- a/ext/Test-Harness/t/sample-tests/switches +++ /dev/null @@ -1,2 +0,0 @@ -print "1..1\n"; -print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n"; diff --git a/ext/Test-Harness/t/sample-tests/taint b/ext/Test-Harness/t/sample-tests/taint deleted file mode 100644 index c36698e042..0000000000 --- a/ext/Test-Harness/t/sample-tests/taint +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/perl -Tw - -use lib qw(t/lib); -use Test::More tests => 1; - -eval { `$^X -e1` }; -like( $@, '/^Insecure dependency/', '-T honored' ); diff --git a/ext/Test-Harness/t/sample-tests/taint_warn b/ext/Test-Harness/t/sample-tests/taint_warn deleted file mode 100644 index 398d6181ee..0000000000 --- a/ext/Test-Harness/t/sample-tests/taint_warn +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/perl -tw - -use lib qw(t/lib); -use Test::More tests => 1; - -my $warnings = ''; -{ - local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; - `$^X -e1`; -} -like( $warnings, '/^Insecure dependency/', '-t honored' ); diff --git a/ext/Test-Harness/t/sample-tests/todo b/ext/Test-Harness/t/sample-tests/todo deleted file mode 100644 index 77f00b4dc9..0000000000 --- a/ext/Test-Harness/t/sample-tests/todo +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY_TEST; -1..5 todo 3 2; -ok 1 -ok 2 -not ok 3 -ok 4 -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/todo_inline b/ext/Test-Harness/t/sample-tests/todo_inline deleted file mode 100644 index 5b96d68caf..0000000000 --- a/ext/Test-Harness/t/sample-tests/todo_inline +++ /dev/null @@ -1,6 +0,0 @@ -print <<DUMMY_TEST; -1..3 -not ok 1 - Foo # TODO Just testing the todo interface. -ok 2 - Unexpected success # TODO Just testing the todo interface. -ok 3 - This is not todo -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/todo_misparse b/ext/Test-Harness/t/sample-tests/todo_misparse deleted file mode 100644 index 138f3fbaaa..0000000000 --- a/ext/Test-Harness/t/sample-tests/todo_misparse +++ /dev/null @@ -1,5 +0,0 @@ -print <<'END'; -1..1 -not ok 1 Hamlette # TODOORNOTTODO -END - diff --git a/ext/Test-Harness/t/sample-tests/too_many b/ext/Test-Harness/t/sample-tests/too_many deleted file mode 100644 index 46acaded4d..0000000000 --- a/ext/Test-Harness/t/sample-tests/too_many +++ /dev/null @@ -1,14 +0,0 @@ -print <<DUMMY; -1..3 -ok 1 -ok 2 -ok 3 -ok 4 -ok 5 -ok 6 -ok 7 -DUMMY - -exit 4; # simulate Test::More's exit status - - diff --git a/ext/Test-Harness/t/sample-tests/version_good b/ext/Test-Harness/t/sample-tests/version_good deleted file mode 100644 index 9e4ab908a2..0000000000 --- a/ext/Test-Harness/t/sample-tests/version_good +++ /dev/null @@ -1,9 +0,0 @@ -print <<DUMMY_TEST; -TAP version 13 -1..5 -ok 1 -ok 2 -ok 3 -ok 4 -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/version_late b/ext/Test-Harness/t/sample-tests/version_late deleted file mode 100644 index 4537a322e3..0000000000 --- a/ext/Test-Harness/t/sample-tests/version_late +++ /dev/null @@ -1,9 +0,0 @@ -print <<DUMMY_TEST; -1..5 -TAP version 13 -ok 1 -ok 2 -ok 3 -ok 4 -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/version_old b/ext/Test-Harness/t/sample-tests/version_old deleted file mode 100644 index 3c0c44ffb1..0000000000 --- a/ext/Test-Harness/t/sample-tests/version_old +++ /dev/null @@ -1,9 +0,0 @@ -print <<DUMMY_TEST; -TAP version 12 -1..5 -ok 1 -ok 2 -ok 3 -ok 4 -ok 5 -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/vms_nit b/ext/Test-Harness/t/sample-tests/vms_nit deleted file mode 100644 index 1df7804309..0000000000 --- a/ext/Test-Harness/t/sample-tests/vms_nit +++ /dev/null @@ -1,6 +0,0 @@ -print <<DUMMY; -1..2 -not -ok 1 -ok 2 -DUMMY diff --git a/ext/Test-Harness/t/sample-tests/with_comments b/ext/Test-Harness/t/sample-tests/with_comments deleted file mode 100644 index 7aa913985b..0000000000 --- a/ext/Test-Harness/t/sample-tests/with_comments +++ /dev/null @@ -1,14 +0,0 @@ -print <<DUMMY_TEST; -# and stuff -1..5 todo 1 2 4 5; -# yeah, that -not ok 1 -# Failed test 1 in t/todo.t at line 9 *TODO* -ok 2 # (t/todo.t at line 10 TODO?!) -ok 3 -not ok 4 -# Test 4 got: '0' (t/todo.t at line 12 *TODO*) -# Expected: '1' (need more tuits) -ok 5 # (t/todo.t at line 13 TODO?!) -# woo -DUMMY_TEST diff --git a/ext/Test-Harness/t/sample-tests/zero_valid b/ext/Test-Harness/t/sample-tests/zero_valid deleted file mode 100644 index dae91a18fb..0000000000 --- a/ext/Test-Harness/t/sample-tests/zero_valid +++ /dev/null @@ -1,8 +0,0 @@ -print <<DUMMY; -1..5 -ok 1 - One -ok 2 - Two -ok - Three -ok 0 - Four -ok 5 - Five -DUMMY diff --git a/ext/Test-Harness/t/scheduler.t b/ext/Test-Harness/t/scheduler.t deleted file mode 100644 index b2742078b1..0000000000 --- a/ext/Test-Harness/t/scheduler.t +++ /dev/null @@ -1,225 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use lib 't/lib'; - -use Test::More; -use TAP::Parser::Scheduler; - -my $perl_rules = { - par => [ - { seq => '../ext/DB_File/t/*' }, - { seq => '../ext/IO_Compress_Zlib/t/*' }, - { seq => '../lib/CPANPLUS/*' }, - { seq => '../lib/ExtUtils/t/*' }, - '*' - ] -}; - -my $incomplete_rules = { par => [ { seq => [ '*A', '*D' ] } ] }; - -my $some_tests = [ - '../ext/DB_File/t/A', - 'foo', - '../ext/DB_File/t/B', - '../ext/DB_File/t/C', - '../lib/CPANPLUS/D', - '../lib/CPANPLUS/E', - 'bar', - '../lib/CPANPLUS/F', - '../ext/DB_File/t/D', - '../ext/DB_File/t/E', - '../ext/DB_File/t/F', -]; - -my @schedule = ( - { name => 'Sequential, no rules', - tests => $some_tests, - jobs => 1, - }, - { name => 'Sequential, Perl rules', - rules => $perl_rules, - tests => $some_tests, - jobs => 1, - }, - { name => 'Two in parallel, Perl rules', - rules => $perl_rules, - tests => $some_tests, - jobs => 2, - }, - { name => 'Massively parallel, Perl rules', - rules => $perl_rules, - tests => $some_tests, - jobs => 1000, - }, - { name => 'Massively parallel, no rules', - tests => $some_tests, - jobs => 1000, - }, - { name => 'Sequential, incomplete rules', - rules => $incomplete_rules, - tests => $some_tests, - jobs => 1, - }, - { name => 'Two in parallel, incomplete rules', - rules => $incomplete_rules, - tests => $some_tests, - jobs => 2, - }, - { name => 'Massively parallel, incomplete rules', - rules => $incomplete_rules, - tests => $some_tests, - jobs => 1000, - }, -); - -plan tests => @schedule * 2 + 266; - -for my $test (@schedule) { - test_scheduler( - $test->{name}, - $test->{tests}, - $test->{rules}, - $test->{jobs} - ); -} - -# An ad-hoc test - -{ - my @tests = qw( - A1 A2 A3 B1 C1 C8 C5 C7 C4 C6 C3 C2 C9 D1 D2 D3 E3 E2 E1 - ); - - my $rules = { - par => [ - { seq => 'A*' }, - { par => 'B*' }, - { seq => [ 'C1', 'C2' ] }, - { par => [ - { seq => [ 'C3', 'C4', 'C5' ] }, - { seq => [ 'C6', 'C7', 'C8' ] } - ] - }, - { seq => [ - { par => ['D*'] }, - { par => ['E*'] } - ] - }, - ] - }; - - my $scheduler = TAP::Parser::Scheduler->new( - tests => \@tests, - rules => $rules - ); - - # diag $scheduler->as_string; - - my $A1 = ok_job( $scheduler, 'A1' ); - my $B1 = ok_job( $scheduler, 'B1' ); - finish($A1); - my $A2 = ok_job( $scheduler, 'A2' ); - my $C1 = ok_job( $scheduler, 'C1' ); - finish( $A2, $C1 ); - my $A3 = ok_job( $scheduler, 'A3' ); - my $C2 = ok_job( $scheduler, 'C2' ); - finish( $A3, $C2 ); - my $C3 = ok_job( $scheduler, 'C3' ); - my $C6 = ok_job( $scheduler, 'C6' ); - my $D1 = ok_job( $scheduler, 'D1' ); - my $D2 = ok_job( $scheduler, 'D2' ); - finish($C6); - my $C7 = ok_job( $scheduler, 'C7' ); - my $D3 = ok_job( $scheduler, 'D3' ); - ok_job( $scheduler, '#' ); - ok_job( $scheduler, '#' ); - finish( $D3, $C3, $D1, $B1 ); - my $C4 = ok_job( $scheduler, 'C4' ); - finish( $C4, $C7 ); - my $C5 = ok_job( $scheduler, 'C5' ); - my $C8 = ok_job( $scheduler, 'C8' ); - ok_job( $scheduler, '#' ); - finish($D2); - my $E3 = ok_job( $scheduler, 'E3' ); - my $E2 = ok_job( $scheduler, 'E2' ); - my $E1 = ok_job( $scheduler, 'E1' ); - finish( $E1, $E2, $E3, $C5, $C8 ); - my $C9 = ok_job( $scheduler, 'C9' ); - ok_job( $scheduler, undef ); -} - -{ - my @tests = (); - for my $t ( 'A' .. 'Z' ) { - push @tests, map {"$t$_"} 1 .. 9; - } - my $rules = { par => [ map { { seq => "$_*" } } 'A' .. 'Z' ] }; - - my $scheduler = TAP::Parser::Scheduler->new( - tests => \@tests, - rules => $rules - ); - - # diag $scheduler->as_string; - - for my $n ( 1 .. 9 ) { - my @got = (); - push @got, ok_job( $scheduler, "$_$n" ) for 'A' .. 'Z'; - ok_job( $scheduler, $n == 9 ? undef : '#' ); - finish(@got); - } -} - -sub finish { $_->finish for @_ } - -sub ok_job { - my ( $scheduler, $want ) = @_; - my $job = $scheduler->get_job; - if ( !defined $want ) { - ok !defined $job, 'undef'; - } - elsif ( $want eq '#' ) { - ok $job->is_spinner, 'spinner'; - } - else { - is $job->filename, $want, $want; - } - return $job; -} - -sub test_scheduler { - my ( $name, $tests, $rules, $jobs ) = @_; - - ok my $scheduler = TAP::Parser::Scheduler->new( - tests => $tests, - defined $rules ? ( rules => $rules ) : (), - ), - "$name: new"; - - # diag $scheduler->as_string; - - my @pipeline = (); - my @got = (); - - while ( defined( my $job = $scheduler->get_job ) ) { - - # diag $scheduler->as_string; - if ( $job->is_spinner || @pipeline >= $jobs ) { - die "Oops! Spinner!" unless @pipeline; - my $done = shift @pipeline; - $done->finish; - - # diag "Completed ", $done->filename; - } - next if $job->is_spinner; - - # diag " Got ", $job->filename; - push @pipeline, $job; - - push @got, $job->filename; - } - - is_deeply [ sort @got ], [ sort @$tests ], "$name: got all tests"; -} - diff --git a/ext/Test-Harness/t/source.t b/ext/Test-Harness/t/source.t deleted file mode 100644 index ce9063e57b..0000000000 --- a/ext/Test-Harness/t/source.t +++ /dev/null @@ -1,93 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; - -use Test::More tests => 26; - -use File::Spec; - -use EmptyParser; -use TAP::Parser::Source; -use TAP::Parser::Source::Perl; - -my $parser = EmptyParser->new; -my $test = File::Spec->catfile( - 't', - 'source_tests', - 'source' -); - -my $perl = $^X; - -can_ok 'TAP::Parser::Source', 'new'; -my $source = TAP::Parser::Source->new; -isa_ok $source, 'TAP::Parser::Source'; - -can_ok $source, 'source'; -eval { $source->source("$perl -It/lib $test") }; -ok my $error = $@, '... and calling it with a string should fail'; -like $error, qr/^Argument to &source must be an array reference/, - '... with an appropriate error message'; -ok $source->source( [ $perl, '-It/lib', '-T', $test ] ), - '... and calling it with valid args should succeed'; - -can_ok $source, 'get_stream'; -my $stream = $source->get_stream($parser); - -isa_ok $stream, 'TAP::Parser::Iterator::Process', - 'get_stream returns the right object'; -can_ok $stream, 'next'; -is $stream->next, '1..1', '... and the first line should be correct'; -is $stream->next, 'ok 1', '... as should the second'; -ok !$stream->next, '... and we should have no more results'; - -can_ok 'TAP::Parser::Source::Perl', 'new'; -$source = TAP::Parser::Source::Perl->new; -isa_ok $source, 'TAP::Parser::Source::Perl', '... and the object it returns'; - -can_ok $source, 'source'; -ok $source->source( [$test] ), - '... and calling it with valid args should succeed'; - -can_ok $source, 'get_stream'; -$stream = $source->get_stream($parser); - -isa_ok $stream, 'TAP::Parser::Iterator::Process', - '... and the object it returns'; -can_ok $stream, 'next'; -is $stream->next, '1..1', '... and the first line should be correct'; -is $stream->next, 'ok 1', '... as should the second'; -ok !$stream->next, '... and we should have no more results'; - -# internals tests! - -can_ok $source, '_switches'; -ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ), - '... and it should find the taint switch' -); - -# coverage test for TAP::PArser::Source - -{ - - # coverage for method get_steam - - my $source = TAP::Parser::Source->new( { parser => $parser } ); - - my @die; - - eval { - local $SIG{__DIE__} = sub { push @die, @_ }; - - $source->get_stream; - }; - - is @die, 1, 'coverage testing of get_stream'; - - like pop @die, qr/No command found!/, '...and it failed as expect'; -} - diff --git a/ext/Test-Harness/t/source_tests/harness b/ext/Test-Harness/t/source_tests/harness deleted file mode 100644 index 7fef7d5459..0000000000 --- a/ext/Test-Harness/t/source_tests/harness +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/perl - -print <<'END_TESTS'; -1..1 -ok 1 - this is a test -END_TESTS diff --git a/ext/Test-Harness/t/source_tests/harness_badtap b/ext/Test-Harness/t/source_tests/harness_badtap deleted file mode 100644 index bf8233a5ca..0000000000 --- a/ext/Test-Harness/t/source_tests/harness_badtap +++ /dev/null @@ -1,8 +0,0 @@ -#!/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 diff --git a/ext/Test-Harness/t/source_tests/harness_complain b/ext/Test-Harness/t/source_tests/harness_complain deleted file mode 100644 index 1ef4cf0534..0000000000 --- a/ext/Test-Harness/t/source_tests/harness_complain +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/perl - -print "1..1\n"; - -die "I should have no args -- @ARGV" if (@ARGV); -print "ok 1 - this is a test\n"; - diff --git a/ext/Test-Harness/t/source_tests/harness_directives b/ext/Test-Harness/t/source_tests/harness_directives deleted file mode 100644 index 91ada58bf3..0000000000 --- a/ext/Test-Harness/t/source_tests/harness_directives +++ /dev/null @@ -1,8 +0,0 @@ -#!/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 diff --git a/ext/Test-Harness/t/source_tests/harness_failure b/ext/Test-Harness/t/source_tests/harness_failure deleted file mode 100644 index a36e5c129b..0000000000 --- a/ext/Test-Harness/t/source_tests/harness_failure +++ /dev/null @@ -1,11 +0,0 @@ -#!/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 diff --git a/ext/Test-Harness/t/source_tests/source b/ext/Test-Harness/t/source_tests/source deleted file mode 100644 index be28995e63..0000000000 --- a/ext/Test-Harness/t/source_tests/source +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/perl -wT - -BEGIN { - if ( $ENV{PERL_CORE} ) { - @INC = ( '../../lib', 't/lib' ); - } - else { - unshift @INC, 't/lib'; - } -} - -use Test::More tests => 1; - -ok 1; diff --git a/ext/Test-Harness/t/spool.t b/ext/Test-Harness/t/spool.t deleted file mode 100644 index d22ffcdd77..0000000000 --- a/ext/Test-Harness/t/spool.t +++ /dev/null @@ -1,139 +0,0 @@ -#!/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 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; - -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, - stream => - TAP::Parser::IteratorFactory->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'; -} diff --git a/ext/Test-Harness/t/state.t b/ext/Test-Harness/t/state.t deleted file mode 100644 index 2d94e9bbce..0000000000 --- a/ext/Test-Harness/t/state.t +++ /dev/null @@ -1,251 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; -use Test::More; -use App::Prove::State; -use App::Prove::State::Result; - -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.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.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.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.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.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.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.t', - ], - }, - { options => 'fast', - get_tests_args => [], - expect => [ - 't/source.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.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.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 = @{ $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 => { - '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, - }, - } - } - ); -} diff --git a/ext/Test-Harness/t/state_results.t b/ext/Test-Harness/t/state_results.t deleted file mode 100644 index fe0b944333..0000000000 --- a/ext/Test-Harness/t/state_results.t +++ /dev/null @@ -1,148 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -use strict; -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, - }, - } - }; -} diff --git a/ext/Test-Harness/t/streams.t b/ext/Test-Harness/t/streams.t deleted file mode 100644 index b312ae8367..0000000000 --- a/ext/Test-Harness/t/streams.t +++ /dev/null @@ -1,171 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -use lib 't/lib'; - -use Test::More tests => 47; - -use TAP::Parser; -use TAP::Parser::IteratorFactory; - -my $STREAMED = 'TAP::Parser'; -my $ITER = 'TAP::Parser::Iterator'; -my $ITER_FH = "${ITER}::Stream"; -my $ITER_ARRAY = "${ITER}::Array"; - -my $factory = TAP::Parser::IteratorFactory->new; -my $stream = $factory->make_iterator( \*DATA ); -isa_ok $stream, 'TAP::Parser::Iterator'; -my $parser = TAP::Parser->new( { stream => $stream } ); -isa_ok $parser, 'TAP::Parser', - '... and creating a streamed parser should succeed'; - -can_ok $parser, '_stream'; -is ref $parser->_stream, $ITER_FH, - '... and it should return the proper iterator'; -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 - -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -ok $parser = TAP::Parser->new( { stream => $stream } ), - 'Now we create a parser with the plan at the end'; -isa_ok $parser->_stream, $ITER_ARRAY, - '... 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 - -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); - -ok $parser = TAP::Parser->new( { stream => $stream } ), - 'Now we create a parser with a plan as the second line'; -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 - -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); - -ok $parser = TAP::Parser->new( { stream => $stream } ), - 'Now we create a parser with the plan as the second to last line'; -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 diff --git a/ext/Test-Harness/t/subclass_tests/non_perl_source b/ext/Test-Harness/t/subclass_tests/non_perl_source deleted file mode 100644 index 12f0f74012..0000000000 --- a/ext/Test-Harness/t/subclass_tests/non_perl_source +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh -echo "1..1" -echo "ok 1 - this is a test" diff --git a/ext/Test-Harness/t/subclass_tests/perl_source b/ext/Test-Harness/t/subclass_tests/perl_source deleted file mode 100644 index 7fef7d5459..0000000000 --- a/ext/Test-Harness/t/subclass_tests/perl_source +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/perl - -print <<'END_TESTS'; -1..1 -ok 1 - this is a test -END_TESTS diff --git a/ext/Test-Harness/t/taint.t b/ext/Test-Harness/t/taint.t deleted file mode 100644 index 2812fc4375..0000000000 --- a/ext/Test-Harness/t/taint.t +++ /dev/null @@ -1,49 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib'; -} - -# Test that options in PERL5OPT are propogated to tainted tests - -use strict; -use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 1 ) ); - -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 -} - -1; diff --git a/ext/Test-Harness/t/testargs.t b/ext/Test-Harness/t/testargs.t deleted file mode 100644 index aa3aa7337c..0000000000 --- a/ext/Test-Harness/t/testargs.t +++ /dev/null @@ -1,128 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use lib 't/lib'; - -use Test::More tests => 19; -use File::Spec; -use TAP::Parser; -use TAP::Harness; -use App::Prove; - -my $test = File::Spec->catfile( - 't', - 'sample-tests', - 'echo' -); - -diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV; - -sub echo_ok { - my $options = shift; - 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; - for (@got) { - is $_->description, shift(@args), - join( ', ', keys %$options ) . ": option passed OK"; - } -} - -for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) { - echo_ok( { source => $test }, @$args ); - echo_ok( { exec => [ $^X, $test ] }, @$args ); -} - -{ - my $harness = TAP::Harness->new( - { verbosity => -9, test_args => [qw( magic hat brigade )] } ); - my $aggregate = $harness->runtests($test); - - is $aggregate->total, 3, "ran the right number of tests"; - is $aggregate->passed, 3, "and they passed"; -} - -package Test::Prove; - -use vars qw(@ISA); -@ISA = '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; -} diff --git a/ext/Test-Harness/t/unicode.t b/ext/Test-Harness/t/unicode.t deleted file mode 100644 index 88d32081ba..0000000000 --- a/ext/Test-Harness/t/unicode.t +++ /dev/null @@ -1,125 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -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"; - } - } - } - } -} diff --git a/ext/Test-Harness/t/utils.t b/ext/Test-Harness/t/utils.t deleted file mode 100644 index 4851ac1f1c..0000000000 --- a/ext/Test-Harness/t/utils.t +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use lib 't/lib'; - -use TAP::Parser::Utils qw( split_shell ); -use Test::More; - -my @schedule = ( - { name => 'Bare words', - in => 'bare words are here', - out => [ 'bare', 'words', 'are', 'here' ], - }, - { name => 'Single quotes', - in => "'bare' 'words' 'are' 'here'", - out => [ 'bare', 'words', 'are', 'here' ], - }, - { name => 'Double quotes', - in => '"bare" "words" "are" "here"', - out => [ 'bare', 'words', 'are', 'here' ], - }, - { name => 'Escapes', - in => '\ "ba\"re" \'wo\\\'rds\' \\\\"are" "here"', - out => [ ' ', 'ba"re', "wo'rds", '\\are', 'here' ], - }, - { name => 'Flag', - in => '-e "system(shift)"', - out => [ '-e', 'system(shift)' ], - }, - { name => 'Nada', - in => undef, - out => [], - }, - { name => 'Nada II', - in => '', - out => [], - }, - { name => 'Zero', - in => 0, - out => ['0'], - }, - { name => 'Empty', - in => '""', - out => [''], - }, - { name => 'Empty II', - in => "''", - out => [''], - }, -); - -plan tests => 1 * @schedule; - -for my $test (@schedule) { - my $name = $test->{name}; - my @got = split_shell( $test->{in} ); - unless ( is_deeply \@got, $test->{out}, "$name: parse OK" ) { - use Data::Dumper; - diag( Dumper( { want => $test->{out}, got => \@got } ) ); - } -} diff --git a/ext/Test-Harness/t/yamlish-output.t b/ext/Test-Harness/t/yamlish-output.t deleted file mode 100644 index 914d7ea237..0000000000 --- a/ext/Test-Harness/t/yamlish-output.t +++ /dev/null @@ -1,100 +0,0 @@ -#!/usr/bin/perl -wT - -use strict; -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"; -} diff --git a/ext/Test-Harness/t/yamlish-writer.t b/ext/Test-Harness/t/yamlish-writer.t deleted file mode 100644 index f7a22c3dab..0000000000 --- a/ext/Test-Harness/t/yamlish-writer.t +++ /dev/null @@ -1,274 +0,0 @@ -#!/usr/bin/perl - -use strict; -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"; - } -} - diff --git a/ext/Test-Harness/t/yamlish.t b/ext/Test-Harness/t/yamlish.t deleted file mode 100644 index 76ba7982b4..0000000000 --- a/ext/Test-Harness/t/yamlish.t +++ /dev/null @@ -1,529 +0,0 @@ -#!perl -w - -use strict; -use lib 't/lib'; - -use Test::More; - -use TAP::Parser::YAMLish::Reader; - -my @SCHEDULE; - -BEGIN { - @SCHEDULE = ( - { name => 'Hello World', - in => [ - '--- Hello, World', - '...', - ], - out => "Hello, World", - }, - { name => 'Hello World 2', - in => [ - '--- \'Hello, \'\'World\'', - '...', - ], - out => "Hello, 'World", - }, - { name => 'Hello World 3', - in => [ - '--- "Hello, World"', - '...', - ], - out => "Hello, World", - }, - { name => 'Hello World 4', - in => [ - '--- "Hello, World"', - '...', - ], - out => "Hello, World", - }, - { name => 'Hello World 4', - in => [ - '--- >', - ' Hello,', - ' World', - '...', - ], - out => "Hello, World\n", - }, - { name => 'Hello World Block', - in => [ - '--- |', - ' Hello,', - ' World', - '...', - ], - out => "Hello,\n World\n", - }, - { name => 'Hello World 5', - in => [ - '--- >', - ' Hello,', - ' World', - '...', - ], - error => qr{Missing\s+'[.][.][.]'}, - }, - { name => 'Simple array', - in => [ - '---', - '- 1', - '- 2', - '- 3', - '...', - ], - out => [ '1', '2', '3' ], - }, - { name => 'Mixed array', - in => [ - '---', - '- 1', - '- \'two\'', - '- "three\n"', - '...', - ], - out => [ '1', 'two', "three\n" ], - }, - { name => 'Hash in array', - in => [ - '---', - '- 1', - '- two: 2', - '- 3', - '...', - ], - out => [ '1', { two => '2' }, '3' ], - }, - { name => 'Hash in array 2', - in => [ - '---', - '- 1', - '- two: 2', - ' three: 3', - '- 4', - '...', - ], - out => [ '1', { two => '2', three => '3' }, '4' ], - }, - { name => 'Nested array', - in => [ - '---', - '- one', - '-', - ' - two', - ' -', - ' - three', - ' - four', - '- five', - '...', - ], - out => [ 'one', [ 'two', ['three'], 'four' ], 'five' ], - }, - { name => 'Nested hash', - in => [ - '---', - 'one:', - ' five: 5', - ' two:', - ' four: 4', - ' three: 3', - 'six: 6', - '...', - ], - out => { - one => { two => { three => '3', four => '4' }, five => '5' }, - six => '6' - }, - }, - { name => 'Space after colon', - in => [ '---', 'spog: ', ' - 1', ' - 2', '...' ], - out => { spog => [ 1, 2 ] }, - }, - { name => 'Original YAML::Tiny test', - in => [ - '---', - 'invoice: 34843', - 'date : 2001-01-23', - 'bill-to:', - ' given : Chris', - ' family : Dumars', - ' address:', - ' lines: |', - ' 458 Walkman Dr.', - ' Suite #292', - ' city : Royal Oak', - ' state : MI', - ' postal : 48046', - 'product:', - ' - sku : BL394D', - ' quantity : 4', - ' description : Basketball', - ' price : 450.00', - ' - sku : BL4438H', - ' quantity : 1', - ' description : Super Hoop', - ' price : 2392.00', - 'tax : 251.42', - 'total: 4443.52', - 'comments: >', - ' Late afternoon is best.', - ' Backup contact is Nancy', - ' Billsmer @ 338-4338', - '...', - ], - out => { - 'bill-to' => { - 'given' => 'Chris', - 'address' => { - 'city' => 'Royal Oak', - 'postal' => '48046', - 'lines' => "458 Walkman Dr.\nSuite #292\n", - 'state' => 'MI' - }, - 'family' => 'Dumars' - }, - 'invoice' => '34843', - 'date' => '2001-01-23', - 'tax' => '251.42', - 'product' => [ - { 'sku' => 'BL394D', - 'quantity' => '4', - 'price' => '450.00', - 'description' => 'Basketball' - }, - { 'sku' => 'BL4438H', - 'quantity' => '1', - 'price' => '2392.00', - 'description' => 'Super Hoop' - } - ], - 'comments' => - "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", - 'total' => '4443.52' - } - }, - - # Tests harvested from YAML::Tiny - { in => ['...'], - name => 'Regression: empty', - error => qr{document\s+header\s+not\s+found} - }, - { in => [ - '# comment', - '...' - ], - name => 'Regression: only_comment', - error => qr{document\s+header\s+not\s+found} - }, - { out => undef, - in => [ - '---', - '...' - ], - name => 'Regression: only_header', - error => qr{Premature\s+end}i, - }, - { out => undef, - in => [ - '---', - '---', - '...' - ], - name => 'Regression: two_header', - error => qr{Unexpected\s+start}i, - }, - { out => undef, - in => [ - '--- ~', - '...' - ], - name => 'Regression: one_undef' - }, - { out => undef, - in => [ - '--- ~', - '...' - ], - name => 'Regression: one_undef2' - }, - { in => [ - '--- ~', - '---', - '...' - ], - name => 'Regression: two_undef', - error => qr{Missing\s+'[.][.][.]'}, - }, - { out => 'foo', - in => [ - '--- foo', - '...' - ], - name => 'Regression: one_scalar', - }, - { out => 'foo', - in => [ - '--- foo', - '...' - ], - name => 'Regression: one_scalar2', - }, - { in => [ - '--- foo', - '--- bar', - '...' - ], - name => 'Regression: two_scalar', - error => qr{Missing\s+'[.][.][.]'}, - }, - { out => ['foo'], - in => [ - '---', - '- foo', - '...' - ], - name => 'Regression: one_list1' - }, - { out => [ - 'foo', - 'bar' - ], - in => [ - '---', - '- foo', - '- bar', - '...' - ], - name => 'Regression: one_list2' - }, - { out => [ - undef, - 'bar' - ], - in => [ - '---', - '- ~', - '- bar', - '...' - ], - name => 'Regression: one_listundef' - }, - { out => { 'foo' => 'bar' }, - in => [ - '---', - 'foo: bar', - '...' - ], - name => 'Regression: one_hash1' - }, - { out => { - 'foo' => 'bar', - 'this' => undef - }, - in => [ - '---', - 'foo: bar', - 'this: ~', - '...' - ], - name => 'Regression: one_hash2' - }, - { out => { - 'foo' => [ - 'bar', - undef, - 'baz' - ] - }, - in => [ - '---', - 'foo:', - ' - bar', - ' - ~', - ' - baz', - '...' - ], - name => 'Regression: array_in_hash' - }, - { out => { - 'bar' => { 'foo' => 'bar' }, - 'foo' => undef - }, - in => [ - '---', - 'foo: ~', - 'bar:', - ' foo: bar', - '...' - ], - name => 'Regression: hash_in_hash' - }, - { out => [ - { 'foo' => undef, - 'this' => 'that' - }, - 'foo', undef, - { 'foo' => 'bar', - 'this' => 'that' - } - ], - in => [ - '---', - '-', - ' foo: ~', - ' this: that', - '- foo', - '- ~', - '-', - ' foo: bar', - ' this: that', - '...' - ], - name => 'Regression: hash_in_array' - }, - { out => ['foo'], - in => [ - '---', - '- \'foo\'', - '...' - ], - name => 'Regression: single_quote1' - }, - { out => [' '], - in => [ - '---', - '- \' \'', - '...' - ], - name => 'Regression: single_spaces' - }, - { out => [''], - in => [ - '---', - '- \'\'', - '...' - ], - name => 'Regression: single_null' - }, - { out => ' ', - in => [ - '--- " "', - '...' - ], - name => 'Regression: only_spaces' - }, - { out => [ - undef, - { 'foo' => 'bar', - 'this' => 'that' - }, - 'baz' - ], - in => [ - '---', - '- ~', - '- foo: bar', - ' this: that', - '- baz', - '...' - ], - name => 'Regression: inline_nested_hash' - }, - { name => "Unprintables", - in => [ - "---", - "- \"\\z\\x01\\x02\\x03\\x04\\x05\\x06\\a\\x08\\t\\n\\v\\f\\r\\x0e\\x0f\"", - "- \"\\x10\\x11\\x12\\x13\\x14\\x15\\x16\\x17\\x18\\x19\\x1a\\e\\x1c\\x1d\\x1e\\x1f\"", - "- \" !\\\"#\$%&'()*+,-./\"", - "- 0123456789:;<=>?", - "- '\@ABCDEFGHIJKLMNO'", - "- 'PQRSTUVWXYZ[\\]^_'", - "- '`abcdefghijklmno'", - "- 'pqrstuvwxyz{|}~\177'", - "- \200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", - "- \220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", - "- \240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", - "- \260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", - "- \300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", - "- \320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", - "- \340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", - "- \360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377", - "..." - ], - out => [ - "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17", - "\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37", - " !\"#\$%&'()*+,-./", - "0123456789:;<=>?", - "\@ABCDEFGHIJKLMNO", - "PQRSTUVWXYZ[\\]^_", - "`abcdefghijklmno", - "pqrstuvwxyz{|}~\177", - "\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", - "\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", - "\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", - "\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", - "\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", - "\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", - "\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", - "\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377" - ], - }, - { name => 'Quoted hash keys', - in => [ - '---', - ' "quoted": Magic!', - ' "\n\t": newline, tab', - '...', - ], - out => { - quoted => 'Magic!', - "\n\t" => 'newline, tab', - }, - }, - { name => 'Empty', - in => [], - out => undef, - }, - ); - - plan tests => @SCHEDULE * 5; -} - -sub iter { - my $ar = shift; - return sub { - return shift @$ar; - }; -} - -for my $test (@SCHEDULE) { - my $name = $test->{name}; - ok my $yaml = TAP::Parser::YAMLish::Reader->new, "$name: Created"; - isa_ok $yaml, 'TAP::Parser::YAMLish::Reader'; - - my $source = join( "\n", @{ $test->{in} } ) . "\n"; - - my $iter = iter( $test->{in} ); - my $got = eval { $yaml->read($iter) }; - - my $raw = $yaml->get_raw; - - if ( my $err = $test->{error} ) { - unless ( like $@, $err, "$name: Error message" ) { - diag "Error: $@\n"; - } - ok !$got, "$name: No result"; - pass; - } - else { - my $want = $test->{out}; - unless ( ok !$@, "$name: No error" ) { - diag "Error: $@\n"; - } - is_deeply $got, $want, "$name: Result matches"; - is $raw, $source, "$name: Captured source matches"; - } -} |