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 /cpan/Test-Harness | |
| parent | 8d4ff56f76907d1619ddc5fd7040d3823057ec47 (diff) | |
| download | perl-b8a2040150d386de90994afd87f9d01bd861104a.tar.gz | |
Move Test::Harness from ext/ to cpan/
Diffstat (limited to 'cpan/Test-Harness')
180 files changed, 27371 insertions, 0 deletions
diff --git a/cpan/Test-Harness/Changes b/cpan/Test-Harness/Changes new file mode 100644 index 0000000000..6141f78f36 --- /dev/null +++ b/cpan/Test-Harness/Changes @@ -0,0 +1,682 @@ +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/cpan/Test-Harness/bin/prove b/cpan/Test-Harness/bin/prove new file mode 100644 index 0000000000..a592a80f0d --- /dev/null +++ b/cpan/Test-Harness/bin/prove @@ -0,0 +1,305 @@ +#!/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/cpan/Test-Harness/lib/App/Prove.pm b/cpan/Test-Harness/lib/App/Prove.pm new file mode 100644 index 0000000000..fd431ed2f0 --- /dev/null +++ b/cpan/Test-Harness/lib/App/Prove.pm @@ -0,0 +1,774 @@ +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/cpan/Test-Harness/lib/App/Prove/State.pm b/cpan/Test-Harness/lib/App/Prove/State.pm new file mode 100644 index 0000000000..202f7aadd3 --- /dev/null +++ b/cpan/Test-Harness/lib/App/Prove/State.pm @@ -0,0 +1,517 @@ +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/cpan/Test-Harness/lib/App/Prove/State/Result.pm b/cpan/Test-Harness/lib/App/Prove/State/Result.pm new file mode 100644 index 0000000000..274676a62f --- /dev/null +++ b/cpan/Test-Harness/lib/App/Prove/State/Result.pm @@ -0,0 +1,233 @@ +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/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm new file mode 100644 index 0000000000..231f78919e --- /dev/null +++ b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm @@ -0,0 +1,153 @@ +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/cpan/Test-Harness/lib/TAP/Base.pm b/cpan/Test-Harness/lib/TAP/Base.pm new file mode 100644 index 0000000000..f88ad11134 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Base.pm @@ -0,0 +1,129 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/Base.pm b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm new file mode 100644 index 0000000000..f2b54a9ba3 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm @@ -0,0 +1,449 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/Color.pm b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm new file mode 100644 index 0000000000..349d3b84bf --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm @@ -0,0 +1,148 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/Console.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm new file mode 100644 index 0000000000..aeca2f2b0d --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm @@ -0,0 +1,91 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm new file mode 100644 index 0000000000..b6b5134cda --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm @@ -0,0 +1,202 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm new file mode 100644 index 0000000000..675512c71d --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm @@ -0,0 +1,219 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/File.pm b/cpan/Test-Harness/lib/TAP/Formatter/File.pm new file mode 100644 index 0000000000..8514bc068b --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/File.pm @@ -0,0 +1,58 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm new file mode 100644 index 0000000000..c6abfd63bc --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm @@ -0,0 +1,110 @@ +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/cpan/Test-Harness/lib/TAP/Formatter/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm new file mode 100644 index 0000000000..21767e5eba --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm @@ -0,0 +1,183 @@ +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/cpan/Test-Harness/lib/TAP/Harness.pm b/cpan/Test-Harness/lib/TAP/Harness.pm new file mode 100644 index 0000000000..749e7af416 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Harness.pm @@ -0,0 +1,830 @@ +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/cpan/Test-Harness/lib/TAP/Object.pm b/cpan/Test-Harness/lib/TAP/Object.pm new file mode 100644 index 0000000000..498bb805c9 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Object.pm @@ -0,0 +1,139 @@ +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/cpan/Test-Harness/lib/TAP/Parser.pm b/cpan/Test-Harness/lib/TAP/Parser.pm new file mode 100644 index 0000000000..ea3acd907f --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser.pm @@ -0,0 +1,1873 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm new file mode 100644 index 0000000000..10b37ef72a --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm @@ -0,0 +1,416 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm new file mode 100644 index 0000000000..44f28a0491 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm @@ -0,0 +1,580 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm new file mode 100644 index 0000000000..09d40bebcc --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm @@ -0,0 +1,165 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm new file mode 100644 index 0000000000..1513d5b994 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm @@ -0,0 +1,106 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm new file mode 100644 index 0000000000..a0a5a8ed32 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm @@ -0,0 +1,377 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm new file mode 100644 index 0000000000..c92cbabe08 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm @@ -0,0 +1,112 @@ +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/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm new file mode 100644 index 0000000000..064d7beb16 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm @@ -0,0 +1,171 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm new file mode 100644 index 0000000000..2e5d929688 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm @@ -0,0 +1,195 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result.pm b/cpan/Test-Harness/lib/TAP/Parser/Result.pm new file mode 100644 index 0000000000..b01e95c5d9 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result.pm @@ -0,0 +1,300 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm new file mode 100644 index 0000000000..3e42f4110f --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm @@ -0,0 +1,63 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm new file mode 100644 index 0000000000..1e9ba13c5f --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm @@ -0,0 +1,61 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm new file mode 100644 index 0000000000..67c01df200 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm @@ -0,0 +1,120 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm new file mode 100644 index 0000000000..3eb62b3322 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm @@ -0,0 +1,63 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm new file mode 100644 index 0000000000..11cf302de6 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm @@ -0,0 +1,274 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm new file mode 100644 index 0000000000..52e19585d9 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm @@ -0,0 +1,51 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm new file mode 100644 index 0000000000..b97681eb06 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm @@ -0,0 +1,63 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm new file mode 100644 index 0000000000..ada3ae445b --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm @@ -0,0 +1,62 @@ +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/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm new file mode 100644 index 0000000000..46d0df29db --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm @@ -0,0 +1,189 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm new file mode 100644 index 0000000000..f1817093af --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm @@ -0,0 +1,312 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm new file mode 100644 index 0000000000..7ab68f9f67 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm @@ -0,0 +1,107 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm new file mode 100644 index 0000000000..10af5e3369 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm @@ -0,0 +1,53 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Source.pm b/cpan/Test-Harness/lib/TAP/Parser/Source.pm new file mode 100644 index 0000000000..9263e9e544 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Source.pm @@ -0,0 +1,173 @@ +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/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm b/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm new file mode 100644 index 0000000000..1f4f2e1428 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm @@ -0,0 +1,326 @@ +package TAP::Parser::Source::Perl; + +use strict; +use Config; +use vars qw($VERSION @ISA); + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => ( $^O eq 'VMS' ); + +use TAP::Parser::Source; +use TAP::Parser::Utils qw( split_shell ); + +@ISA = 'TAP::Parser::Source'; + +=head1 NAME + +TAP::Parser::Source::Perl - Stream Perl output + +=head1 VERSION + +Version 3.17 + +=cut + +$VERSION = '3.17'; + +=head1 SYNOPSIS + + use TAP::Parser::Source::Perl; + my $perl = TAP::Parser::Source::Perl->new; + my $stream = $perl->source( [ $filename, @args ] )->get_stream; + +=head1 DESCRIPTION + +Takes a filename and hopefully returns a stream from it. The filename should +be the name of a Perl program. + +Note that this is a subclass of L<TAP::Parser::Source>. See that module for +more methods. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + + my $perl = TAP::Parser::Source::Perl->new; + +Returns a new C<TAP::Parser::Source::Perl> object. + +=head2 Instance Methods + +=head3 C<source> + +Getter/setter the name of the test program and any arguments it requires. + + my ($filename, @args) = @{ $perl->source }; + $perl->source( [ $filename, @args ] ); + +C<croak>s if C<$filename> could not be found. + +=cut + +sub source { + my $self = shift; + $self->_croak("Cannot find ($_[0][0])") + if @_ && !-f $_[0][0]; + return $self->SUPER::source(@_); +} + +=head3 C<switches> + + my $switches = $perl->switches; + my @switches = $perl->switches; + $perl->switches( \@switches ); + +Getter/setter for the additional switches to pass to the perl executable. One +common switch would be to set an include directory: + + $perl->switches( ['-Ilib'] ); + +=cut + +sub switches { + my $self = shift; + unless (@_) { + return wantarray ? @{ $self->{switches} } : $self->{switches}; + } + my $switches = shift; + $self->{switches} = [@$switches]; # force a copy + return $self; +} + +############################################################################## + +=head3 C<get_stream> + + my $stream = $source->get_stream($parser); + +Returns a stream of the output generated by executing C<source>. Must be +passed an object that implements a C<make_iterator> method. Typically +this is a TAP::Parser instance. + +=cut + +sub get_stream { + my ( $self, $factory ) = @_; + + my @switches = $self->_switches; + my $path_sep = $Config{path_sep}; + my $path_pat = qr{$path_sep}; + + # Filter out any -I switches to be handled as libs later. + # + # Nasty kludge. It might be nicer if we got the libs separately + # although at least this way we find any -I switches that were + # supplied other then as explicit libs. + # + # We filter out any names containing colons because they will break + # PERL5LIB + my @libs; + my @filtered_switches; + for (@switches) { + if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { + push @libs, $1; + } + else { + push @filtered_switches, $_; + } + } + @switches = @filtered_switches; + + my $setup = sub { + if (@libs) { + $ENV{PERL5LIB} + = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); + } + }; + + # Cargo culted from comments seen elsewhere about VMS / environment + # variables. I don't know if this is actually necessary. + my $previous = $ENV{PERL5LIB}; + my $teardown = sub { + if ( defined $previous ) { + $ENV{PERL5LIB} = $previous; + } + else { + delete $ENV{PERL5LIB}; + } + }; + + # Taint mode ignores environment variables so we must retranslate + # PERL5LIB as -I switches and place PERL5OPT on the command line + # in order that it be seen. + if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { + push @switches, $self->_libs2switches(@libs); + push @switches, split_shell( $ENV{PERL5OPT} ); + } + + my @command = $self->_get_command_for_switches(@switches) + or $self->_croak("No command found!"); + + return $factory->make_iterator( + { command => \@command, + merge => $self->merge, + setup => $setup, + teardown => $teardown, + } + ); +} + +sub _get_command_for_switches { + my $self = shift; + my @switches = @_; + my ( $file, @args ) = @{ $self->source }; + my $command = $self->_get_perl; + +# XXX we never need to quote if we treat the parts as atoms (except maybe vms) +#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); + my @command = ( $command, @switches, $file, @args ); + return @command; +} + +sub _get_command { + my $self = shift; + return $self->_get_command_for_switches( $self->_switches ); +} + +sub _libs2switches { + my $self = shift; + return map {"-I$_"} grep {$_} @_; +} + +=head3 C<shebang> + +Get the shebang line for a script file. + + my $shebang = TAP::Parser::Source::Perl->shebang( $some_script ); + +May be called as a class method + +=cut + +{ + + # Global shebang cache. + my %shebang_for; + + sub _read_shebang { + my $file = shift; + local *TEST; + my $shebang; + if ( open( TEST, $file ) ) { + $shebang = <TEST>; + close(TEST) or print "Can't close $file. $!\n"; + } + else { + print "Can't open $file. $!\n"; + } + return $shebang; + } + + sub shebang { + my ( $class, $file ) = @_; + unless ( exists $shebang_for{$file} ) { + $shebang_for{$file} = _read_shebang($file); + } + return $shebang_for{$file}; + } +} + +=head3 C<get_taint> + +Decode any taint switches from a Perl shebang line. + + # $taint will be 't' + my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' ); + + # $untaint will be undefined + my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' ); + +=cut + +sub get_taint { + my ( $class, $shebang ) = @_; + return + unless defined $shebang + && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; + return $1; +} + +sub _switches { + my $self = shift; + my ( $file, @args ) = @{ $self->source }; + my @switches = ( + $self->switches, + ); + + my $shebang = $self->shebang($file); + return unless defined $shebang; + + my $taint = $self->get_taint($shebang); + push @switches, "-$taint" if defined $taint; + + # Quote the argument if we're VMS, since VMS will downcase anything + # not quoted. + if (IS_VMS) { + for (@switches) { + $_ = qq["$_"]; + } + } + + return @switches; +} + +sub _get_perl { + my $self = shift; + return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; + return Win32::GetShortPathName($^X) if IS_WIN32; + return $^X; +} + +1; + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head2 Example + + package MyPerlSource; + + use strict; + use vars '@ISA'; + + use Carp qw( croak ); + use TAP::Parser::Source::Perl; + + @ISA = qw( TAP::Parser::Source::Perl ); + + sub source { + my ($self, $args) = @_; + if ($args) { + $self->{file} = $args->[0]; + return $self->SUPER::source($args); + } + return $self->SUPER::source; + } + + # use the version of perl from the shebang line in the test file + sub _get_perl { + my $self = shift; + if (my $shebang = $self->shebang( $self->{file} )) { + $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; + return $1 if $1; + } + return $self->SUPER::_get_perl(@_); + } + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::Source>, + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Utils.pm b/cpan/Test-Harness/lib/TAP/Parser/Utils.pm new file mode 100644 index 0000000000..a3d2dd1ea9 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/Utils.pm @@ -0,0 +1,72 @@ +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/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm new file mode 100644 index 0000000000..524d7dca8d --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm @@ -0,0 +1,333 @@ +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/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm new file mode 100644 index 0000000000..ed81f6d819 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm @@ -0,0 +1,255 @@ +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/cpan/Test-Harness/lib/Test/Harness.pm b/cpan/Test-Harness/lib/Test/Harness.pm new file mode 100644 index 0000000000..eba3c5efc4 --- /dev/null +++ b/cpan/Test-Harness/lib/Test/Harness.pm @@ -0,0 +1,585 @@ +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/cpan/Test-Harness/t/000-load.t b/cpan/Test-Harness/t/000-load.t new file mode 100644 index 0000000000..58d41bfeeb --- /dev/null +++ b/cpan/Test-Harness/t/000-load.t @@ -0,0 +1,61 @@ +#!/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/cpan/Test-Harness/t/aggregator.t b/cpan/Test-Harness/t/aggregator.t new file mode 100644 index 0000000000..c8e32a1c93 --- /dev/null +++ b/cpan/Test-Harness/t/aggregator.t @@ -0,0 +1,305 @@ +#!/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/cpan/Test-Harness/t/bailout.t b/cpan/Test-Harness/t/bailout.t new file mode 100644 index 0000000000..e10b133e0f --- /dev/null +++ b/cpan/Test-Harness/t/bailout.t @@ -0,0 +1,114 @@ +#!/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/cpan/Test-Harness/t/base.t b/cpan/Test-Harness/t/base.t new file mode 100644 index 0000000000..4fee54844e --- /dev/null +++ b/cpan/Test-Harness/t/base.t @@ -0,0 +1,173 @@ +#!/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/cpan/Test-Harness/t/callbacks.t b/cpan/Test-Harness/t/callbacks.t new file mode 100644 index 0000000000..18c6f0d15e --- /dev/null +++ b/cpan/Test-Harness/t/callbacks.t @@ -0,0 +1,116 @@ +#!/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/cpan/Test-Harness/t/compat/env.t b/cpan/Test-Harness/t/compat/env.t new file mode 100644 index 0000000000..ac5c096213 --- /dev/null +++ b/cpan/Test-Harness/t/compat/env.t @@ -0,0 +1,39 @@ +#!/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/cpan/Test-Harness/t/compat/failure.t b/cpan/Test-Harness/t/compat/failure.t new file mode 100644 index 0000000000..2f80e57884 --- /dev/null +++ b/cpan/Test-Harness/t/compat/failure.t @@ -0,0 +1,56 @@ +#!/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/cpan/Test-Harness/t/compat/inc-propagation.t b/cpan/Test-Harness/t/compat/inc-propagation.t new file mode 100644 index 0000000000..c0d62b0407 --- /dev/null +++ b/cpan/Test-Harness/t/compat/inc-propagation.t @@ -0,0 +1,57 @@ +#!/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/cpan/Test-Harness/t/compat/inc_taint.t b/cpan/Test-Harness/t/compat/inc_taint.t new file mode 100644 index 0000000000..3bd86b4108 --- /dev/null +++ b/cpan/Test-Harness/t/compat/inc_taint.t @@ -0,0 +1,33 @@ +#!/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/cpan/Test-Harness/t/compat/nonumbers.t b/cpan/Test-Harness/t/compat/nonumbers.t new file mode 100644 index 0000000000..144a7599b2 --- /dev/null +++ b/cpan/Test-Harness/t/compat/nonumbers.t @@ -0,0 +1,14 @@ +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/cpan/Test-Harness/t/compat/regression.t b/cpan/Test-Harness/t/compat/regression.t new file mode 100644 index 0000000000..50a4d516c8 --- /dev/null +++ b/cpan/Test-Harness/t/compat/regression.t @@ -0,0 +1,19 @@ +#!/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/cpan/Test-Harness/t/compat/switches.t b/cpan/Test-Harness/t/compat/switches.t new file mode 100644 index 0000000000..42b16c8bd4 --- /dev/null +++ b/cpan/Test-Harness/t/compat/switches.t @@ -0,0 +1,17 @@ +#!/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/cpan/Test-Harness/t/compat/test-harness-compat.t b/cpan/Test-Harness/t/compat/test-harness-compat.t new file mode 100644 index 0000000000..cae9a54333 --- /dev/null +++ b/cpan/Test-Harness/t/compat/test-harness-compat.t @@ -0,0 +1,851 @@ +#!/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/cpan/Test-Harness/t/compat/version.t b/cpan/Test-Harness/t/compat/version.t new file mode 100644 index 0000000000..08344cbd9c --- /dev/null +++ b/cpan/Test-Harness/t/compat/version.t @@ -0,0 +1,11 @@ +#!/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/cpan/Test-Harness/t/console.t b/cpan/Test-Harness/t/console.t new file mode 100644 index 0000000000..32f5db62ac --- /dev/null +++ b/cpan/Test-Harness/t/console.t @@ -0,0 +1,47 @@ +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/cpan/Test-Harness/t/data/catme.1 b/cpan/Test-Harness/t/data/catme.1 new file mode 100644 index 0000000000..7ecdd9a102 --- /dev/null +++ b/cpan/Test-Harness/t/data/catme.1 @@ -0,0 +1,2 @@ +1..1 +ok 1 diff --git a/cpan/Test-Harness/t/data/proverc b/cpan/Test-Harness/t/data/proverc new file mode 100644 index 0000000000..9d2924145d --- /dev/null +++ b/cpan/Test-Harness/t/data/proverc @@ -0,0 +1,7 @@ +--should be --split correctly # No comment! +Can "quote things" 'using single or' "double quotes" + +# More stuff +--this +is +'OK?' diff --git a/cpan/Test-Harness/t/data/sample.yml b/cpan/Test-Harness/t/data/sample.yml new file mode 100644 index 0000000000..6c4b7fbf4a --- /dev/null +++ b/cpan/Test-Harness/t/data/sample.yml @@ -0,0 +1,29 @@ +--- +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/cpan/Test-Harness/t/errors.t b/cpan/Test-Harness/t/errors.t new file mode 100644 index 0000000000..3a54cbe066 --- /dev/null +++ b/cpan/Test-Harness/t/errors.t @@ -0,0 +1,183 @@ +#!/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/cpan/Test-Harness/t/file.t b/cpan/Test-Harness/t/file.t new file mode 100644 index 0000000000..f97d1aadd0 --- /dev/null +++ b/cpan/Test-Harness/t/file.t @@ -0,0 +1,475 @@ +#!/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/cpan/Test-Harness/t/glob-to-regexp.t b/cpan/Test-Harness/t/glob-to-regexp.t new file mode 100644 index 0000000000..493daab307 --- /dev/null +++ b/cpan/Test-Harness/t/glob-to-regexp.t @@ -0,0 +1,44 @@ +#!/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/cpan/Test-Harness/t/grammar.t b/cpan/Test-Harness/t/grammar.t new file mode 100644 index 0000000000..b74fc8ba65 --- /dev/null +++ b/cpan/Test-Harness/t/grammar.t @@ -0,0 +1,455 @@ +#!/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/cpan/Test-Harness/t/harness-bailout.t b/cpan/Test-Harness/t/harness-bailout.t new file mode 100644 index 0000000000..fd1dc35669 --- /dev/null +++ b/cpan/Test-Harness/t/harness-bailout.t @@ -0,0 +1,54 @@ +#!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/cpan/Test-Harness/t/harness-subclass.t b/cpan/Test-Harness/t/harness-subclass.t new file mode 100644 index 0000000000..c6b46daa21 --- /dev/null +++ b/cpan/Test-Harness/t/harness-subclass.t @@ -0,0 +1,65 @@ +#!/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/cpan/Test-Harness/t/harness.t b/cpan/Test-Harness/t/harness.t new file mode 100644 index 0000000000..3643f576f3 --- /dev/null +++ b/cpan/Test-Harness/t/harness.t @@ -0,0 +1,982 @@ +#!/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/cpan/Test-Harness/t/iterators.t b/cpan/Test-Harness/t/iterators.t new file mode 100644 index 0000000000..d190be9289 --- /dev/null +++ b/cpan/Test-Harness/t/iterators.t @@ -0,0 +1,215 @@ +#!/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/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm new file mode 100644 index 0000000000..81f79ea042 --- /dev/null +++ b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm @@ -0,0 +1,9 @@ +package App::Prove::Plugin::Dummy; + +use strict; + +sub import { + main::test_log_import(@_); +} + +1; diff --git a/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm new file mode 100644 index 0000000000..ae80003e62 --- /dev/null +++ b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm @@ -0,0 +1,13 @@ +package App::Prove::Plugin::Dummy2; + +use strict; + +sub import { + main::test_log_import(@_); +} + +sub load { + main::test_log_plugin_load(@_); +} + +1; diff --git a/cpan/Test-Harness/t/lib/Dev/Null.pm b/cpan/Test-Harness/t/lib/Dev/Null.pm new file mode 100644 index 0000000000..09ca5d6627 --- /dev/null +++ b/cpan/Test-Harness/t/lib/Dev/Null.pm @@ -0,0 +1,18 @@ +# 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/cpan/Test-Harness/t/lib/EmptyParser.pm b/cpan/Test-Harness/t/lib/EmptyParser.pm new file mode 100644 index 0000000000..2f7ec2428e --- /dev/null +++ b/cpan/Test-Harness/t/lib/EmptyParser.pm @@ -0,0 +1,30 @@ +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/cpan/Test-Harness/t/lib/IO/c55Capture.pm b/cpan/Test-Harness/t/lib/IO/c55Capture.pm new file mode 100644 index 0000000000..ecbcb49ba7 --- /dev/null +++ b/cpan/Test-Harness/t/lib/IO/c55Capture.pm @@ -0,0 +1,120 @@ +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/cpan/Test-Harness/t/lib/MyCustom.pm b/cpan/Test-Harness/t/lib/MyCustom.pm new file mode 100644 index 0000000000..2402312edc --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyCustom.pm @@ -0,0 +1,12 @@ +# 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/cpan/Test-Harness/t/lib/MyGrammar.pm b/cpan/Test-Harness/t/lib/MyGrammar.pm new file mode 100644 index 0000000000..ef93f9dfc1 --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyGrammar.pm @@ -0,0 +1,21 @@ +# 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/cpan/Test-Harness/t/lib/MyIterator.pm b/cpan/Test-Harness/t/lib/MyIterator.pm new file mode 100644 index 0000000000..561f6e2c78 --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyIterator.pm @@ -0,0 +1,26 @@ +# 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/cpan/Test-Harness/t/lib/MyIteratorFactory.pm b/cpan/Test-Harness/t/lib/MyIteratorFactory.pm new file mode 100644 index 0000000000..d8c3269cda --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyIteratorFactory.pm @@ -0,0 +1,19 @@ +# subclass for testing customizing & subclassing + +package MyIteratorFactory; + +use strict; +use vars '@ISA'; + +use MyCustom; +use MyIterator; +use TAP::Parser::IteratorFactory; + +@ISA = qw( TAP::Parser::IteratorFactory MyCustom ); + +sub make_iterator { + my $class = shift; + return MyIterator->new(@_); +} + +1; diff --git a/cpan/Test-Harness/t/lib/MyPerlSource.pm b/cpan/Test-Harness/t/lib/MyPerlSource.pm new file mode 100644 index 0000000000..6193db97df --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyPerlSource.pm @@ -0,0 +1,27 @@ +# subclass for testing customizing & subclassing + +package MyPerlSource; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::Source::Perl; + +@ISA = qw( TAP::Parser::Source::Perl MyCustom ); + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + return $self; +} + +sub source { + my $self = shift; + return $self->SUPER::source(@_); +} + +1; + diff --git a/cpan/Test-Harness/t/lib/MyResult.pm b/cpan/Test-Harness/t/lib/MyResult.pm new file mode 100644 index 0000000000..ab4845dedf --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyResult.pm @@ -0,0 +1,21 @@ +# 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/cpan/Test-Harness/t/lib/MyResultFactory.pm b/cpan/Test-Harness/t/lib/MyResultFactory.pm new file mode 100644 index 0000000000..371bba632b --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyResultFactory.pm @@ -0,0 +1,23 @@ +# 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/cpan/Test-Harness/t/lib/MySource.pm b/cpan/Test-Harness/t/lib/MySource.pm new file mode 100644 index 0000000000..5e41b829ae --- /dev/null +++ b/cpan/Test-Harness/t/lib/MySource.pm @@ -0,0 +1,34 @@ +# subclass for testing customizing & subclassing + +package MySource; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::Source; + +@ISA = qw( TAP::Parser::Source MyCustom ); + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + return $self; +} + +sub source { + my $self = shift; + return $self->SUPER::source(@_); +} + +sub get_stream { + my $self = shift; + my $stream = $self->SUPER::get_stream(@_); + + # re-bless it: + bless $stream, 'MyIterator'; +} + +1; diff --git a/cpan/Test-Harness/t/lib/NOP.pm b/cpan/Test-Harness/t/lib/NOP.pm new file mode 100644 index 0000000000..6de1dbfbd5 --- /dev/null +++ b/cpan/Test-Harness/t/lib/NOP.pm @@ -0,0 +1,7 @@ +package NOP; + +# Do nothing much + +sub new { bless {}, shift } + +1; diff --git a/cpan/Test-Harness/t/lib/NoFork.pm b/cpan/Test-Harness/t/lib/NoFork.pm new file mode 100644 index 0000000000..0225e9628d --- /dev/null +++ b/cpan/Test-Harness/t/lib/NoFork.pm @@ -0,0 +1,21 @@ +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/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm b/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm new file mode 100644 index 0000000000..84becee932 --- /dev/null +++ b/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm @@ -0,0 +1,39 @@ +# 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/cpan/Test-Harness/t/multiplexer.t b/cpan/Test-Harness/t/multiplexer.t new file mode 100644 index 0000000000..649d5d161f --- /dev/null +++ b/cpan/Test-Harness/t/multiplexer.t @@ -0,0 +1,170 @@ +#!/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/cpan/Test-Harness/t/nofork-mux.t b/cpan/Test-Harness/t/nofork-mux.t new file mode 100644 index 0000000000..4f28bf8c1d --- /dev/null +++ b/cpan/Test-Harness/t/nofork-mux.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl -w + +BEGIN { + use lib 't/lib'; +} + +use strict; + +use NoFork; +require( 't/multiplexer.t' ); diff --git a/cpan/Test-Harness/t/nofork.t b/cpan/Test-Harness/t/nofork.t new file mode 100644 index 0000000000..1d8b340e1b --- /dev/null +++ b/cpan/Test-Harness/t/nofork.t @@ -0,0 +1,59 @@ +#!/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/cpan/Test-Harness/t/object.t b/cpan/Test-Harness/t/object.t new file mode 100644 index 0000000000..b1a4dd0b98 --- /dev/null +++ b/cpan/Test-Harness/t/object.t @@ -0,0 +1,37 @@ +#!/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/cpan/Test-Harness/t/parse.t b/cpan/Test-Harness/t/parse.t new file mode 100644 index 0000000000..f0def28c9a --- /dev/null +++ b/cpan/Test-Harness/t/parse.t @@ -0,0 +1,1058 @@ +#!/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/cpan/Test-Harness/t/parser-config.t b/cpan/Test-Harness/t/parser-config.t new file mode 100644 index 0000000000..bd3625902d --- /dev/null +++ b/cpan/Test-Harness/t/parser-config.t @@ -0,0 +1,39 @@ +#!/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/cpan/Test-Harness/t/parser-subclass.t b/cpan/Test-Harness/t/parser-subclass.t new file mode 100644 index 0000000000..303c28ca27 --- /dev/null +++ b/cpan/Test-Harness/t/parser-subclass.t @@ -0,0 +1,80 @@ +#!/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/cpan/Test-Harness/t/perl5lib.t b/cpan/Test-Harness/t/perl5lib.t new file mode 100644 index 0000000000..51113e156b --- /dev/null +++ b/cpan/Test-Harness/t/perl5lib.t @@ -0,0 +1,51 @@ +#!/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/cpan/Test-Harness/t/premature-bailout.t b/cpan/Test-Harness/t/premature-bailout.t new file mode 100644 index 0000000000..9226a44064 --- /dev/null +++ b/cpan/Test-Harness/t/premature-bailout.t @@ -0,0 +1,125 @@ +#!/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/cpan/Test-Harness/t/process.t b/cpan/Test-Harness/t/process.t new file mode 100644 index 0000000000..5135d67f95 --- /dev/null +++ b/cpan/Test-Harness/t/process.t @@ -0,0 +1,53 @@ +#!/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/cpan/Test-Harness/t/prove.t b/cpan/Test-Harness/t/prove.t new file mode 100644 index 0000000000..71730cdbf6 --- /dev/null +++ b/cpan/Test-Harness/t/prove.t @@ -0,0 +1,1525 @@ +#!/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/cpan/Test-Harness/t/proveenv.t b/cpan/Test-Harness/t/proveenv.t new file mode 100644 index 0000000000..be9942a043 --- /dev/null +++ b/cpan/Test-Harness/t/proveenv.t @@ -0,0 +1,17 @@ +#!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/cpan/Test-Harness/t/proverc.t b/cpan/Test-Harness/t/proverc.t new file mode 100644 index 0000000000..37d6de803b --- /dev/null +++ b/cpan/Test-Harness/t/proverc.t @@ -0,0 +1,23 @@ +#!/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/cpan/Test-Harness/t/proverc/emptyexec b/cpan/Test-Harness/t/proverc/emptyexec new file mode 100644 index 0000000000..5381b8f015 --- /dev/null +++ b/cpan/Test-Harness/t/proverc/emptyexec @@ -0,0 +1,2 @@ +--exec '' + diff --git a/cpan/Test-Harness/t/proverun.t b/cpan/Test-Harness/t/proverun.t new file mode 100644 index 0000000000..6e6c2f33f5 --- /dev/null +++ b/cpan/Test-Harness/t/proverun.t @@ -0,0 +1,176 @@ +#!/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/cpan/Test-Harness/t/regression.t b/cpan/Test-Harness/t/regression.t new file mode 100644 index 0000000000..20879ca2b6 --- /dev/null +++ b/cpan/Test-Harness/t/regression.t @@ -0,0 +1,3264 @@ +#!/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/cpan/Test-Harness/t/results.t b/cpan/Test-Harness/t/results.t new file mode 100644 index 0000000000..0522dd6299 --- /dev/null +++ b/cpan/Test-Harness/t/results.t @@ -0,0 +1,295 @@ +#!/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/cpan/Test-Harness/t/sample-tests/bailout b/cpan/Test-Harness/t/sample-tests/bailout new file mode 100644 index 0000000000..b25f417b52 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/bailout @@ -0,0 +1,11 @@ +# 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/cpan/Test-Harness/t/sample-tests/bignum b/cpan/Test-Harness/t/sample-tests/bignum new file mode 100644 index 0000000000..b5824a12a1 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/bignum @@ -0,0 +1,7 @@ +print <<DUMMY; +1..2 +ok 1 +ok 2 +ok 136211425 +ok 136211426 +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/bignum_many b/cpan/Test-Harness/t/sample-tests/bignum_many new file mode 100644 index 0000000000..1e30b2f1dd --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/bignum_many @@ -0,0 +1,14 @@ +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/cpan/Test-Harness/t/sample-tests/combined b/cpan/Test-Harness/t/sample-tests/combined new file mode 100644 index 0000000000..7e157092b3 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/combined @@ -0,0 +1,13 @@ +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/cpan/Test-Harness/t/sample-tests/combined_compat b/cpan/Test-Harness/t/sample-tests/combined_compat new file mode 100644 index 0000000000..8dfaa28e92 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/combined_compat @@ -0,0 +1,13 @@ +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/cpan/Test-Harness/t/sample-tests/delayed b/cpan/Test-Harness/t/sample-tests/delayed new file mode 100644 index 0000000000..1f24ef6790 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/delayed @@ -0,0 +1,26 @@ +# 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/cpan/Test-Harness/t/sample-tests/descriptive b/cpan/Test-Harness/t/sample-tests/descriptive new file mode 100644 index 0000000000..e165ac1bf5 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/descriptive @@ -0,0 +1,8 @@ +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/cpan/Test-Harness/t/sample-tests/descriptive_trailing b/cpan/Test-Harness/t/sample-tests/descriptive_trailing new file mode 100644 index 0000000000..f92d7ca694 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/descriptive_trailing @@ -0,0 +1,8 @@ +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/cpan/Test-Harness/t/sample-tests/die b/cpan/Test-Harness/t/sample-tests/die new file mode 100644 index 0000000000..ca8b0a9b0b --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die @@ -0,0 +1,2 @@ +eval "use vmsish 'hushed'" if ($^O eq 'VMS'); +exit 1; # exit because die() can be noisy diff --git a/cpan/Test-Harness/t/sample-tests/die_head_end b/cpan/Test-Harness/t/sample-tests/die_head_end new file mode 100644 index 0000000000..494e4d3c82 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die_head_end @@ -0,0 +1,9 @@ +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/cpan/Test-Harness/t/sample-tests/die_last_minute b/cpan/Test-Harness/t/sample-tests/die_last_minute new file mode 100644 index 0000000000..ea533d628e --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die_last_minute @@ -0,0 +1,10 @@ +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/cpan/Test-Harness/t/sample-tests/die_unfinished b/cpan/Test-Harness/t/sample-tests/die_unfinished new file mode 100644 index 0000000000..3efd08ff09 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die_unfinished @@ -0,0 +1,9 @@ +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/cpan/Test-Harness/t/sample-tests/duplicates b/cpan/Test-Harness/t/sample-tests/duplicates new file mode 100644 index 0000000000..63f6a706b6 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/duplicates @@ -0,0 +1,14 @@ +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/cpan/Test-Harness/t/sample-tests/echo b/cpan/Test-Harness/t/sample-tests/echo new file mode 100644 index 0000000000..6696e71f17 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/echo @@ -0,0 +1,2 @@ +print '1..', scalar(@ARGV), "\n"; +print "ok $_ ", $ARGV[ $_ - 1 ], "\n" for 1 .. @ARGV; diff --git a/cpan/Test-Harness/t/sample-tests/empty b/cpan/Test-Harness/t/sample-tests/empty new file mode 100644 index 0000000000..66d42ad402 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/empty @@ -0,0 +1,2 @@ +__END__ +Used to exercise the "empty test" case. diff --git a/cpan/Test-Harness/t/sample-tests/escape_eol b/cpan/Test-Harness/t/sample-tests/escape_eol new file mode 100644 index 0000000000..1b8ba27f1e --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/escape_eol @@ -0,0 +1,5 @@ +print <<DUMMY_TEST; +1..2 +ok 1 Should parse as literal backslash --> \\ +ok 2 Not a continuation line +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/escape_hash b/cpan/Test-Harness/t/sample-tests/escape_hash new file mode 100644 index 0000000000..c404372c0c --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/escape_hash @@ -0,0 +1,6 @@ +print <<DUMMY_TEST; +1..3 +ok 1 Not a \\# TODO +ok 2 Not a \\# SKIP +ok 3 Escaped \\\\\\# +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/head_end b/cpan/Test-Harness/t/sample-tests/head_end new file mode 100644 index 0000000000..14a32f2fe6 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/head_end @@ -0,0 +1,11 @@ +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/cpan/Test-Harness/t/sample-tests/head_fail b/cpan/Test-Harness/t/sample-tests/head_fail new file mode 100644 index 0000000000..9d1667ab19 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/head_fail @@ -0,0 +1,11 @@ +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/cpan/Test-Harness/t/sample-tests/inc_taint b/cpan/Test-Harness/t/sample-tests/inc_taint new file mode 100644 index 0000000000..d1be66706c --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/inc_taint @@ -0,0 +1,6 @@ +#!/usr/bin/perl -Tw + +use Test::More tests => 1; + +ok( grep( /examples/, @INC ) ); + diff --git a/cpan/Test-Harness/t/sample-tests/junk_before_plan b/cpan/Test-Harness/t/sample-tests/junk_before_plan new file mode 100644 index 0000000000..b2ad018301 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/junk_before_plan @@ -0,0 +1,6 @@ +print <<DUMMY_TEST; +this is junk +# this is a comment +1..1 +ok 1 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/lone_not_bug b/cpan/Test-Harness/t/sample-tests/lone_not_bug new file mode 100644 index 0000000000..10eaa2a3b0 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/lone_not_bug @@ -0,0 +1,9 @@ +# 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/cpan/Test-Harness/t/sample-tests/no_nums b/cpan/Test-Harness/t/sample-tests/no_nums new file mode 100644 index 0000000000..c32d3f22ba --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/no_nums @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok +ok +not ok +ok +ok +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/no_output b/cpan/Test-Harness/t/sample-tests/no_output new file mode 100644 index 0000000000..505acda7e6 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/no_output @@ -0,0 +1,3 @@ +#!/usr/bin/perl -w + +exit; diff --git a/cpan/Test-Harness/t/sample-tests/out_err_mix b/cpan/Test-Harness/t/sample-tests/out_err_mix new file mode 100644 index 0000000000..c802eb4a11 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/out_err_mix @@ -0,0 +1,13 @@ +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/cpan/Test-Harness/t/sample-tests/out_of_order b/cpan/Test-Harness/t/sample-tests/out_of_order new file mode 100644 index 0000000000..77641aa362 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/out_of_order @@ -0,0 +1,22 @@ +# 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/cpan/Test-Harness/t/sample-tests/schwern b/cpan/Test-Harness/t/sample-tests/schwern new file mode 100644 index 0000000000..d45726bc7a --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/schwern @@ -0,0 +1,3 @@ +use Test::More; +plan tests => 1; +ok 23, 42; diff --git a/cpan/Test-Harness/t/sample-tests/schwern-todo-quiet b/cpan/Test-Harness/t/sample-tests/schwern-todo-quiet new file mode 100644 index 0000000000..4d482d43fa --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/schwern-todo-quiet @@ -0,0 +1,13 @@ +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/cpan/Test-Harness/t/sample-tests/segfault b/cpan/Test-Harness/t/sample-tests/segfault new file mode 100644 index 0000000000..c5670a42b5 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/segfault @@ -0,0 +1,5 @@ +#!/usr/bin/perl + +print "1..1\n"; +print "ok 1\n"; +kill 11, $$; diff --git a/cpan/Test-Harness/t/sample-tests/sequence_misparse b/cpan/Test-Harness/t/sample-tests/sequence_misparse new file mode 100644 index 0000000000..c66d127bb0 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/sequence_misparse @@ -0,0 +1,14 @@ +# +# 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/cpan/Test-Harness/t/sample-tests/shbang_misparse b/cpan/Test-Harness/t/sample-tests/shbang_misparse new file mode 100644 index 0000000000..ab93b468ae --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/shbang_misparse @@ -0,0 +1,12 @@ +#!/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/cpan/Test-Harness/t/sample-tests/simple b/cpan/Test-Harness/t/sample-tests/simple new file mode 100644 index 0000000000..d6b85846b2 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/simple @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/simple_fail b/cpan/Test-Harness/t/sample-tests/simple_fail new file mode 100644 index 0000000000..aa65f5f66d --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/simple_fail @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok 1 +not ok 2 +ok 3 +ok 4 +not ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/simple_yaml b/cpan/Test-Harness/t/sample-tests/simple_yaml new file mode 100644 index 0000000000..9f52c5c8a8 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/simple_yaml @@ -0,0 +1,27 @@ +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/cpan/Test-Harness/t/sample-tests/skip b/cpan/Test-Harness/t/sample-tests/skip new file mode 100644 index 0000000000..6a9cd662bc --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skip @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok 1 +ok 2 # skip rain delay +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/skip_nomsg b/cpan/Test-Harness/t/sample-tests/skip_nomsg new file mode 100644 index 0000000000..51d1ed6b43 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skip_nomsg @@ -0,0 +1,4 @@ +print <<DUMMY; +1..1 +ok 1 # Skip +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/skipall b/cpan/Test-Harness/t/sample-tests/skipall new file mode 100644 index 0000000000..ceb2c19b3a --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skipall @@ -0,0 +1,3 @@ +print <<DUMMY_TEST; +1..0 # skipping: rope +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/skipall_nomsg b/cpan/Test-Harness/t/sample-tests/skipall_nomsg new file mode 100644 index 0000000000..9b0dc11a69 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skipall_nomsg @@ -0,0 +1,2 @@ +print "1..0\n"; +exit 0; diff --git a/cpan/Test-Harness/t/sample-tests/skipall_v13 b/cpan/Test-Harness/t/sample-tests/skipall_v13 new file mode 100644 index 0000000000..d16bd4f652 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skipall_v13 @@ -0,0 +1,4 @@ +print <<DUMMY_TEST; +TAP version 13 +1..0 # skipping: rope +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/space_after_plan b/cpan/Test-Harness/t/sample-tests/space_after_plan new file mode 100644 index 0000000000..d454c20d4d --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/space_after_plan @@ -0,0 +1,3 @@ +# 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/cpan/Test-Harness/t/sample-tests/stdout_stderr b/cpan/Test-Harness/t/sample-tests/stdout_stderr new file mode 100644 index 0000000000..ce17484d65 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/stdout_stderr @@ -0,0 +1,9 @@ +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/cpan/Test-Harness/t/sample-tests/strict b/cpan/Test-Harness/t/sample-tests/strict new file mode 100644 index 0000000000..b89138de40 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/strict @@ -0,0 +1,9 @@ +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/cpan/Test-Harness/t/sample-tests/switches b/cpan/Test-Harness/t/sample-tests/switches new file mode 100644 index 0000000000..8ce9c9a589 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/switches @@ -0,0 +1,2 @@ +print "1..1\n"; +print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n"; diff --git a/cpan/Test-Harness/t/sample-tests/taint b/cpan/Test-Harness/t/sample-tests/taint new file mode 100644 index 0000000000..c36698e042 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/taint @@ -0,0 +1,7 @@ +#!/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/cpan/Test-Harness/t/sample-tests/taint_warn b/cpan/Test-Harness/t/sample-tests/taint_warn new file mode 100644 index 0000000000..398d6181ee --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/taint_warn @@ -0,0 +1,11 @@ +#!/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/cpan/Test-Harness/t/sample-tests/todo b/cpan/Test-Harness/t/sample-tests/todo new file mode 100644 index 0000000000..77f00b4dc9 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/todo @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 todo 3 2; +ok 1 +ok 2 +not ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/todo_inline b/cpan/Test-Harness/t/sample-tests/todo_inline new file mode 100644 index 0000000000..5b96d68caf --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/todo_inline @@ -0,0 +1,6 @@ +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/cpan/Test-Harness/t/sample-tests/todo_misparse b/cpan/Test-Harness/t/sample-tests/todo_misparse new file mode 100644 index 0000000000..138f3fbaaa --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/todo_misparse @@ -0,0 +1,5 @@ +print <<'END'; +1..1 +not ok 1 Hamlette # TODOORNOTTODO +END + diff --git a/cpan/Test-Harness/t/sample-tests/too_many b/cpan/Test-Harness/t/sample-tests/too_many new file mode 100644 index 0000000000..46acaded4d --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/too_many @@ -0,0 +1,14 @@ +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/cpan/Test-Harness/t/sample-tests/version_good b/cpan/Test-Harness/t/sample-tests/version_good new file mode 100644 index 0000000000..9e4ab908a2 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/version_good @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +TAP version 13 +1..5 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/version_late b/cpan/Test-Harness/t/sample-tests/version_late new file mode 100644 index 0000000000..4537a322e3 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/version_late @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +1..5 +TAP version 13 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/version_old b/cpan/Test-Harness/t/sample-tests/version_old new file mode 100644 index 0000000000..3c0c44ffb1 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/version_old @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +TAP version 12 +1..5 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/vms_nit b/cpan/Test-Harness/t/sample-tests/vms_nit new file mode 100644 index 0000000000..1df7804309 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/vms_nit @@ -0,0 +1,6 @@ +print <<DUMMY; +1..2 +not +ok 1 +ok 2 +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/with_comments b/cpan/Test-Harness/t/sample-tests/with_comments new file mode 100644 index 0000000000..7aa913985b --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/with_comments @@ -0,0 +1,14 @@ +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/cpan/Test-Harness/t/sample-tests/zero_valid b/cpan/Test-Harness/t/sample-tests/zero_valid new file mode 100644 index 0000000000..dae91a18fb --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/zero_valid @@ -0,0 +1,8 @@ +print <<DUMMY; +1..5 +ok 1 - One +ok 2 - Two +ok - Three +ok 0 - Four +ok 5 - Five +DUMMY diff --git a/cpan/Test-Harness/t/scheduler.t b/cpan/Test-Harness/t/scheduler.t new file mode 100644 index 0000000000..b2742078b1 --- /dev/null +++ b/cpan/Test-Harness/t/scheduler.t @@ -0,0 +1,225 @@ +#!/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/cpan/Test-Harness/t/source.t b/cpan/Test-Harness/t/source.t new file mode 100644 index 0000000000..ce9063e57b --- /dev/null +++ b/cpan/Test-Harness/t/source.t @@ -0,0 +1,93 @@ +#!/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/cpan/Test-Harness/t/source_tests/harness b/cpan/Test-Harness/t/source_tests/harness new file mode 100644 index 0000000000..7fef7d5459 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness @@ -0,0 +1,6 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..1 +ok 1 - this is a test +END_TESTS diff --git a/cpan/Test-Harness/t/source_tests/harness_badtap b/cpan/Test-Harness/t/source_tests/harness_badtap new file mode 100644 index 0000000000..bf8233a5ca --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_badtap @@ -0,0 +1,8 @@ +#!/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/cpan/Test-Harness/t/source_tests/harness_complain b/cpan/Test-Harness/t/source_tests/harness_complain new file mode 100644 index 0000000000..1ef4cf0534 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_complain @@ -0,0 +1,7 @@ +#!/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/cpan/Test-Harness/t/source_tests/harness_directives b/cpan/Test-Harness/t/source_tests/harness_directives new file mode 100644 index 0000000000..91ada58bf3 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_directives @@ -0,0 +1,8 @@ +#!/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/cpan/Test-Harness/t/source_tests/harness_failure b/cpan/Test-Harness/t/source_tests/harness_failure new file mode 100644 index 0000000000..a36e5c129b --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_failure @@ -0,0 +1,11 @@ +#!/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/cpan/Test-Harness/t/source_tests/source b/cpan/Test-Harness/t/source_tests/source new file mode 100644 index 0000000000..be28995e63 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source @@ -0,0 +1,14 @@ +#!/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/cpan/Test-Harness/t/spool.t b/cpan/Test-Harness/t/spool.t new file mode 100644 index 0000000000..d22ffcdd77 --- /dev/null +++ b/cpan/Test-Harness/t/spool.t @@ -0,0 +1,139 @@ +#!/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/cpan/Test-Harness/t/state.t b/cpan/Test-Harness/t/state.t new file mode 100644 index 0000000000..2d94e9bbce --- /dev/null +++ b/cpan/Test-Harness/t/state.t @@ -0,0 +1,251 @@ +#!/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/cpan/Test-Harness/t/state_results.t b/cpan/Test-Harness/t/state_results.t new file mode 100644 index 0000000000..fe0b944333 --- /dev/null +++ b/cpan/Test-Harness/t/state_results.t @@ -0,0 +1,148 @@ +#!/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/cpan/Test-Harness/t/streams.t b/cpan/Test-Harness/t/streams.t new file mode 100644 index 0000000000..b312ae8367 --- /dev/null +++ b/cpan/Test-Harness/t/streams.t @@ -0,0 +1,171 @@ +#!/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/cpan/Test-Harness/t/subclass_tests/non_perl_source b/cpan/Test-Harness/t/subclass_tests/non_perl_source new file mode 100644 index 0000000000..12f0f74012 --- /dev/null +++ b/cpan/Test-Harness/t/subclass_tests/non_perl_source @@ -0,0 +1,3 @@ +#!/bin/sh +echo "1..1" +echo "ok 1 - this is a test" diff --git a/cpan/Test-Harness/t/subclass_tests/perl_source b/cpan/Test-Harness/t/subclass_tests/perl_source new file mode 100644 index 0000000000..7fef7d5459 --- /dev/null +++ b/cpan/Test-Harness/t/subclass_tests/perl_source @@ -0,0 +1,6 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..1 +ok 1 - this is a test +END_TESTS diff --git a/cpan/Test-Harness/t/taint.t b/cpan/Test-Harness/t/taint.t new file mode 100644 index 0000000000..2812fc4375 --- /dev/null +++ b/cpan/Test-Harness/t/taint.t @@ -0,0 +1,49 @@ +#!/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/cpan/Test-Harness/t/testargs.t b/cpan/Test-Harness/t/testargs.t new file mode 100644 index 0000000000..aa3aa7337c --- /dev/null +++ b/cpan/Test-Harness/t/testargs.t @@ -0,0 +1,128 @@ +#!/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/cpan/Test-Harness/t/unicode.t b/cpan/Test-Harness/t/unicode.t new file mode 100644 index 0000000000..88d32081ba --- /dev/null +++ b/cpan/Test-Harness/t/unicode.t @@ -0,0 +1,125 @@ +#!/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/cpan/Test-Harness/t/utils.t b/cpan/Test-Harness/t/utils.t new file mode 100644 index 0000000000..4851ac1f1c --- /dev/null +++ b/cpan/Test-Harness/t/utils.t @@ -0,0 +1,61 @@ +#!/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/cpan/Test-Harness/t/yamlish-output.t b/cpan/Test-Harness/t/yamlish-output.t new file mode 100644 index 0000000000..914d7ea237 --- /dev/null +++ b/cpan/Test-Harness/t/yamlish-output.t @@ -0,0 +1,100 @@ +#!/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/cpan/Test-Harness/t/yamlish-writer.t b/cpan/Test-Harness/t/yamlish-writer.t new file mode 100644 index 0000000000..f7a22c3dab --- /dev/null +++ b/cpan/Test-Harness/t/yamlish-writer.t @@ -0,0 +1,274 @@ +#!/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/cpan/Test-Harness/t/yamlish.t b/cpan/Test-Harness/t/yamlish.t new file mode 100644 index 0000000000..76ba7982b4 --- /dev/null +++ b/cpan/Test-Harness/t/yamlish.t @@ -0,0 +1,529 @@ +#!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"; + } +} |