diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-10-02 16:19:41 +0100 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-10-02 16:19:41 +0100 |
| commit | e0ee75a6976f08f9bc3868227f1cd11ab6507895 (patch) | |
| tree | 5366acf520d51f2f3961274ced349a4178685be5 /cpan/Test-Simple | |
| parent | 8c5b8ff02c62badaeb38078556879720bdf8945a (diff) | |
| download | perl-e0ee75a6976f08f9bc3868227f1cd11ab6507895.tar.gz | |
Move Test::Simple from ext/ to cpan/
Diffstat (limited to 'cpan/Test-Simple')
119 files changed, 11723 insertions, 0 deletions
diff --git a/cpan/Test-Simple/Changes b/cpan/Test-Simple/Changes new file mode 100644 index 0000000000..0c955f2908 --- /dev/null +++ b/cpan/Test-Simple/Changes @@ -0,0 +1,738 @@ +0.92 Fri Jul 3 11:08:56 PDT 2009 + Test Fixes + * Silence noise on VMS in exit.t (Craig Berry) + * Skip Builder/fork_with_new_stdout.t on systems without fork (Craig Berry) + + +0.90 Thu Jul 2 13:18:25 PDT 2009 + Docs + * Finally added a note about the "Wide character in print" warning and + how to work around it. + * Note the IO::Stringy license in our copy of it. + [test-more.googlecode.com 47] + + Test Fixes + * Small fixes for integration with the Perl core + [bleadperl eaa0815147e13cd4ab5b3d6ca8f26544a9f0c3b4] + * exit code tests could be effected by errno when PERLIO=stdio + [bleadperl c76230386fc5e6fba9fdbeab473abbf4f4adcbe3] + + Other + * This is a stable release for 5.10.1. It does not include + the subtest() work in 0.89_01. + + +0.88 Sat May 30 12:31:24 PDT 2009 + Turing 0.87_03 into a stable release. + + +0.87_03 Sun May 24 13:41:40 PDT 2009 + New Features + * isa_ok() now works on classes. (Peter Scott) + + +0.87_02 Sat Apr 11 12:54:14 PDT 2009 + Test Fixes + * Some filesystems don't like it when you open a file for writing multiple + times. Fixes t/Builder/reset.t. [rt.cpan.org 17298] + * Check how an operating system is going to map exit codes. Some OS' + will map them... sometimes. [rt.cpan.org 42148] + * Fix Test::Builder::NoOutput on 5.6.2. + + +0.87_01 Sun Mar 29 09:56:52 BST 2009 + New Features + * done_testing() allows you to declare that you have finished running tests, + and how many you ran. It is a safer no_plan and effectively replaces it. + * output() now supports scalar references. + + Feature Changes + * You can now run a test without first declaring a plan. This allows + done_testing() to work. + * You can now call current_test() without first declaring a plan. + + Bug Fixes + * skip_all() with no reason would output "1..0" which is invalid TAP. It will + now always include the SKIP directive. + + Other + * Repository moved to github. + + +0.86 Sun Nov 9 01:09:05 PST 2008 + Same as 0.85_01 + + +0.85_01 Thu Oct 23 18:57:38 PDT 2008 + New Features + * cmp_ok() now displays the error if the comparison throws one. + For example, broken overloaded objects. + + Bug Fixes + * cmp_ok() no longer stringifies or numifies its arguments before comparing. + This makes cmp_ok() properly test overloaded ops. + [rt.cpan.org 24186] [code.google.com 16] + * diag() properly escapes blank lines. + + Feature Changes + * cmp_ok() now reports warnings and errors as coming from inside cmp_ok, + as well as reporting the caller's file and line. This let's the user + know where cmp_ok() was called from while reminding them that it is + being run in a different context. + + Other + * Dependency on ExtUtils::MakeMaker 6.27 only on Windows otherwise the + nested tests won't run. + + +0.84 Wed Oct 15 09:06:12 EDT 2008 + Other + * 0.82 accidentally shipped with experimental Mouse dependency. + + +0.82 Tue Oct 14 23:06:56 EDT 2008 + Bug Fixes + - 0.81_01 broke $TODO such that $TODO = '' was considered todo. + + +0.81_02 Tue Sep 9 04:35:40 PDT 2008 + New Features + * Test::Builder->reset_outputs() to reset all the output methods back to + their defaults. + + Bug Fixes + - Fixed the file and line number reported by like when it gets a bad + regex. + + Features Changed + - Now preserves the tests' exit code if it exits abnormally, rather than + setting it to 255. + - Changed the "Looks like your test died" message to + "Looks like your test exited with $exit_code" + - no_plan now only warns if given an argument. There were a lot of people + doing that, and it's a sensible mistake. [test-more.googlecode.com 13] + + +0.81_01 Sat Sep 6 15:13:50 PDT 2008 + New Features + * Adam Kennedy bribed me to add new_ok(). The price was one DEFCON license key. + [rt.cpan.org 8891] + * TODO tests can now start and end with 'todo_start' and 'todo_end' + Test::Builder methods. [rt.cpan.org 38018] + * Added Test::Builder->in_todo() for a safe way to check if a test is inside a + TODO block. This allows TODO tests with no reason. + * Added note() and explain() to both Test::More and Test::Builder. + [rt.cpan.org 14764] [test-more.googlecode.com 3] + + Features Changed + * Changed the message for extra tests run to show the number of tests run rather than + the number extra to avoid the user having to do mental math. + [rt.cpan.org 7022] + + Bug fixes + - using a relative path to perl broke tests [rt.cpan.org 34050] + - use_ok() broke $SIG{__DIE__} in the used module [rt.cpan.org 34065] + - diagnostics for isnt() were confusing on failure [rt.cpan.org 33642] + - warnings when MakeMaker's version contained _ [rt.cpan.org 33626] + - add explicit test that non-integer plans die correctly [rt.cpan.org 28836] + (Thanks to Hans Dieter Pearcey [confound] for fixing the above) + - die if no_plan is given an argument [rt.cpan.org 27429] + + +0.80 Sun Apr 6 17:25:01 CEST 2008 + Test fixes + - Completely disable the utf8 test. It was causing perl to panic on some OS's. + + +0.79_01 Wed Feb 27 03:04:54 PST 2008 + Bug fixes + - Let's try the IO layer copying again, this time with the test + fixed for 5.10. + + +0.78 Wed Feb 27 01:59:09 PST 2008 + Bug fixes + * Whoops, the version of Test::Builder::Tester got moved backwards. + + +0.77 Wed Feb 27 01:55:55 PST 2008 + Bug fixes + - "use Test::Builder::Module" no longer sets exported_to() or does + any other importing. + - Fix the $TODO finding code so it can find $TODO without the benefit + of exported_to(), which is often wrong. + - Turn off the filehandle locale stuff for the moment, there's a + problem on 5.10. We'll try it again next release. + + Doc improvements + - Improve the Test::Builder SYNOPSIS to use Test::Builder::Module + rather than write it's own import(). + + +0.76_02 Sun Feb 24 13:12:55 PST 2008 + Bug fixes + * The default test output filehandles will NOT use utf8. + They will now copy the IO layers from STDOUT and STDERR. + This means if :utf8 is on then it will honor it and not + warn about wide characters. + + +0.76_01 Sat Feb 23 20:44:32 PST 2008 + Bug fixes + * Test::Builder no longer uses a __DIE__ handler. This resolves a number + of problems with exit codes being swallowed or other module's handlers + being interfered with. [rt.cpan.org 25294] + - Allow maybe_regex() to detect blessed regexes. [bleadperl @32880] + - The default test output filehandles will now use utf8. + [rt.cpan.org 21091] + + Test fixes + - Remove the signature test. Adds no security and just generates + failures. + + +0.75 Sat Feb 23 19:03:38 PST 2008 + Incompatibilities + * The minimum version is now 5.6.0. + + Bug fixes + - Turns out require_ok() had the same bug as use_ok() in a BEGIN block. + - ok() was not honoring exported_to() when looking for $TODO as it + should be. + + Test fixes + * is_deeply_with_threads.t will not run unless AUTHOR_TESTING is set. + This is because it tickles intermittent threading bugs in many perls + and causes a lot of bug reports about which I can do nothing. + + Misc + - Ran through perlcritic and did some cleaning. + +0.74 Thu Nov 29 15:39:57 PST 2007 + Misc + - Add abstract and author to the meta information. + +0.73_01 Mon Oct 15 20:35:15 EDT 2007 + Bug fixes + * Put the use_ok() fix from 0.71 back. + +0.72 Wed Sep 19 20:08:07 PDT 2007 + Bug unfixes + * The BEGIN { use_ok } fix for [rt.cpan.org 28345] revealed a small pile of + mistakes in CPAN module test suites. Rolling the fix back to give the + authors a bit of time to fix their tests. + +0.71 Thu Sep 13 20:42:36 PDT 2007 + Bug fixes + - Fixed a problem with BEGIN { use_ok } silently failing when there's no + plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak. + - Fixed an obscure problem with is_deeply() and overloading == + [rt.cpan.org 20768]. Thanks Sisyphus. + + Test fixes + - Removed dependency on Text::Soundex [rt.cpan.org 25022] + - Fixed a 5.5.x failure in fail-more.t + * Got rid of the annoying sort_bug.t test that revealed problems with some + threaded perls. It was testing the deprecated eq_* functions and not + worth the bother. Now it tests is_deeply(). [rt.cpan.org 17791] + + Doc fixes + - Minor POD mistake in Test::Builder [rt.cpan.org 28869] + * Test::FAQ has been updated with some more answers. + + Install fixes + - Fixed the "LICENSE is not a known MakeMaker parameter name" warning + on older MakeMakers for real this time. + +0.70 Thu Mar 15 15:53:05 PDT 2007 + Bug Fixes + * The change to is_fh() in 0.68 broke the case where a reference to + a tied filehandle is used for perl 5.6 and back. This made the tests + puke their guts out. + +0.69 Wed Mar 14 06:43:35 PDT 2007 + Test fixes + - Minor filename compatibility fix to t/fail-more.t [rt.cpan.org 25428] + +0.68 Tue Mar 13 17:27:26 PDT 2007 + Bug fixes + * If your code has a $SIG{__DIE__} handler in some cases functions like + use_ok(), require_ok(), can_ok() and isa_ok() could trigger that + handler. [rt.cpan.org 23509] + - Minor improvement to TB's filehandle detection in the case of overridden + isa(). [rt.cpan.org 20890] + - Will now install as a core module in 5.6.2 which ships with Test::More. + [rt.cpan.org 25163] + + New Features + - Test::Builder->is_fh() provides a way to determine if a thing + can be used as a filehandle. + + Documentation improvements + - Improved the docs for $Test::Builder::Level showing the encouraged + use (increment, don't set) + - Documented the return value of Test::Builder's test methods + - Split out TB's method documentation to differenciate between test + methods (ok, is_eq...), methods useful in testing (skip, BAILOUT...) + and methods useful for building your own tests (maybe_regex...). + + Test fixes + - We required too old a version of Test::Pod::Coverage. Need 1.08 and not + 1.00. [rt.cpan.org 25351] + +0.67 Mon Jan 22 13:27:40 PST 2007 + Test fixes + - t/pod_coverage.t would fail if Test::Pod::Coverage between 1.07 and + 1.00 were installed as it depended on all_modules being exported. + [rt.cpan.org 24483] + +0.66 Sun Dec 3 15:25:45 PST 2006 + - Restore 5.4.5 compatibility (unobe@cpan.org) [rt.cpan.org 20513] + +0.65 Fri Nov 10 10:26:51 CST 2006 + +0.64_03 Sun Nov 5 13:09:55 EST 2006 + - Tests will no longer warn when run against an alpha version of + Test::Harness [rt.cpan.org #20501] + - Now testing our POD and POD coverage. + - Added a LICENSE field. + - Removed warning from the docs about mixing numbered and unnumbered + tests. There's nothing wrong with that. [rt.cpan.org 21358] + - Change doc examples to talk about $got and $expected rather than + $this and $that to correspond better to the diagnostic output + [rt.cpan.org 2655] + +0.64_02 Sat Sep 9 12:16:56 EDT 2006 + - Last release broke Perls earlier than 5.8. + +0.64_01 Mon Sep 4 04:40:42 EDT 2006 + - Small improvement to the docs to avoid user confusion over + "use Test::More tests => $num_tests" (Thanks Eric Wilhelm) + - Minor fix for a test failure in is_deeply_fail for some Windows + users. Not a real bug. [rt.cpan.org 21310] + - _print_diag() accidentally leaked into the public documentation. + It is a private method. + * Added Test::Builder->carp() and croak() + * Made most of the error messages report in the caller's context. + [rt.cpan.org #20639] + * Made the failure diagnostic message file and line reporting portion + match Perl's for easier integration with Perl aware editors. + (so its "at $file line $line_num." now) + [rt.cpan.org #20639] + * 5.8.0 threads are no longer supported. There's too many bugs. + +0.64 Sun Jul 16 02:47:29 PDT 2006 + * 0.63's change to test_fail() broke backwards compatibility. They + have been removed for the time being. test_pass() went with it. + This is [rt.cpan.org 11317] and [rt.cpan.org 11319]. + - skip() will now warn if you get the args backwards. + +0.63 Sun Jul 9 02:36:36 PDT 2006 + * Fixed can_ok() to gracefully handle no class name. + Submitted by "Pete Krawczyk" <perl@bsod.net> + Implemented by "Richard Foley" <richard.foley@rfi.net> + [rt.cpan.org 15654] + * Added test_pass() to Test::Builder::Tester rather than having to + call test_out("ok 1 - foo"). <chromatic@wgz.org> [rt.cpan.org 11317] + * test_fail() now accepts a test diagnostic rather than having to + call test_out() separately. <chromatic@wgz.org> [rt.cpan.org 11319] + - Changed Test::Builder::Tester docs to show best practice using + test_fail() and test_pass(). + - isnt_num() doc example wrongly showed is_num(). <chromatic@wgz.org> + - Fixed a minor typo in the BAIL_OUT() docs. <Jeff Deifik> + - Removed the LICENSE field from the Makefile.PL as the release of + MakeMaker with that feature has been delayed. + +0.62 Sat Oct 8 01:25:03 PDT 2005 + * Absorbed Test::Builder::Tester. The last release broke it because its + screen scraping Test::More and the failure output changed. By + distributing them together we ensure TBT won't break again. + * Test::Builder->BAILOUT() was missing. + - is_deeply() can now handle function and code refs in a very limited + way. It simply looks to see if they have the same referent. + [rt.cpan.org 14746] + +0.61 Fri Sep 23 23:26:05 PDT 2005 + - create.t was trying to read from a file before it had been closed + (and thus the changes may not have yet been written). + * is_deeply() would call stringification methods on non-object strings + which happened to be the name of a string overloaded class. + [rt.cpan.org 14675] + +0.60_02 Tue Aug 9 00:27:41 PDT 2005 + * Added Test::Builder::Module. + - Changed Test::More and Test::Simple to use Test::Builder::Module + - Minor Win32 testing nit in fail-more.t + * Added no_diag() method to Test::Builder and changed Test::More's + no_diag internals to use that. [rt.cpan.org 8655] + * Deprecated no_diag() as an option to "use Test::More". Call the + Test::Builder method instead. + +0.60_01 Sun Jul 3 18:11:58 PDT 2005 + - Moved the docs around a little to better group all the testing + functions together. [rt.cpan.org 8388] + * Added a BAIL_OUT() function to Test::More [rt.cpan.org 8381] + - Changed Test::Builder->BAILOUT to BAIL_OUT to match other method's + naming conventions. BAILOUT remains but is deprecated. + * Changed the standard failure diagnostics to include the test name. + [rt.cpan.org 12490] + - is_deeply() was broken for overloaded objects in the top level in + 0.59_01. [rt.cpan.org 13506] + - String overloaded objects without an 'eq' or '==' method are now + handled in cmp_ok() and is(). + - cmp_ok() will now treat overloaded objects as numbers if the comparison + operator is numeric. [rt.cpan.org 13156] + - cmp_ok(), like() and unlike will now throw uninit warnings if their + arguments are undefined. [rt.cpan.org 13155] + - cmp_ok() will now throw warnings as if the comparison were run + normally, for example cmp_ok(2, '==', 'foo') will warn about 'foo' + not being numeric. Previously all warnings in the comparison were + supressed. [rt.cpan.org 13155] + - Tests will now report *both* the number of tests failed and if the + wrong number of tests were run. Previously if tests failed and the + wrong number were run it would only report the latter. + [rt.cpan.org 13494] + - Missing or extra tests are not considered failures for the purposes + of calculating the exit code. Should there be no failures but the + wrong number of tests the exit code will be 254. + - Avoiding an unbalanced sort in eq_set() [bugs.perl.org 36354] + - Documenting that eq_set() doesn't deal well with refs. + - Clarified how is_deeply() compares a bit. + * Once again working on 5.4.5. + +0.60 Tue May 3 14:20:34 PDT 2005 + +0.59_01 Tue Apr 26 21:51:12 PDT 2005 + * Test::Builder now has a create() method which allows you to create + a brand spanking new Test::Builder object. + * require_ok() was not working for single letter module names. + * is_deeply() and eq_* now work with circular scalar references + (Thanks Fergal) + * Use of eq_* now officially discouraged. + - Removed eq_* from the SYNOPSIS. + - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441] + - is_deeply() was mistakenly interpeting the same reference used twice + in a data structure as being circular causing failures. + [rt.cpan.org 11623] + - Loading Test::Builder but not using it would interfere with the + exit code if the code exited. [rt.cpan.org 12310] + - is_deeply() diagnostics now disambiguate between stringified references + and references. [rt.cpan.org 8865] + - Files opened by the output methods are now autoflushed. + - todo() now honors $Level when looking for $TODO. + +0.54 Wed Dec 15 04:18:43 EST 2004 + * $how_many is optional for skip() and todo_skip(). Thanks to + Devel::Cover for pointing this out. + - Removed a user defined function called err() in the tests to placate + users of older versions of the dor patch before err() was weakend. + [rt.cpan.org 8734] + +0.53_01 Sat Dec 11 19:02:18 EST 2004 + - current_test() can now be set backward. + - *output() methods now handle tied handles and *FOO{IO} properly. + - maybe_regex() now handles undef gracefully. + - maybe_regex() now handles 'm,foo,' style regexes. + - sort_bug.t wasn't checking for threads properly. Would fail on + 5.6 that had ithreads compiled in. [rt.cpan.org 8765] + +0.53 Mon Nov 29 04:43:24 EST 2004 + - Apparently its possible to have Module::Signature installed without + it being functional. Fixed the signature test to account for this. + (not a real bug) + +0.52 Sun Nov 28 21:41:03 EST 2004 + - plan() now better checks that the given plan is valid. + [rt.cpan.org 2597] + +0.51_02 Sat Nov 27 01:25:25 EST 2004 + * is_deeply() and all the eq_* functions now handle circular data + structures. [rt.cpan.org 7289] + * require_ok() now handles filepaths in addition to modules. + - Clarifying Test::More's position on overloaded objects + - Fixed a bug introduced in 0.51_01 causing is_deeply() to pierce + overloaded objects. + - Mentioning rt.cpan.org for reporting bugs. + +0.51_01 Fri Nov 26 02:59:30 EST 2004 + - plan() was accidentally exporting functions [rt.cpan.org 8385] + * diag @msgs would insert # between arguments. [rt.cpan.org 8392] + * eq_set() could cause problems under threads due to a weird sort bug + [rt.cpan.org 6782] + * undef no longer equals '' in is_deeply() [rt.cpan.org 6837] + * is_deeply() would sometimes compare references as strings. + [rt.cpan.org 7031] + - eq_array() and eq_hash() could hold onto references if they failed + keeping them in memory and preventing DESTROY. [rt.cpan.org 7032] + * is_deeply() could confuse [] with a non-existing value + [rt.cpan.org 7030] + - is_deeply() diagnostics a little off when scalar refs were inside + an array or hash ref [rt.cpan.org 7033] + - Thanks to Fergal Daly for ferretting out all these long standing + is_deeply and eq_* bugs. + +0.51 Tue Nov 23 04:51:12 EST 2004 + - Fixed bug in fail_one.t on Windows (not a real bug). + - TODO reasons as overloaded objects now won't blow up under threads. + [Autrijus Tang] + - skip() in 0.50 tickled yet another bug in threads::shared. Hacked + around it. + +0.50 Sat Nov 20 00:28:44 EST 2004 + - Fixed bug in fail-more test on Windows (not a real bug). + [rt.cpan.org 8022] + - Change from CVS to SVK. Hopefully this is the last time I move + version control systems. + - Again removing File::Spec dependency (came back in 0.48_02) + - Change from Aegis back to CVS + +0.49 Thu Oct 14 21:58:50 EDT 2004 + - t/harness_active.t would fail for frivolous reasons with older + MakeMakers (test bug) [thanks Bill Moseley for noticing] + +0.48_02 Mon Jul 19 02:07:23 EDT 2004 + * Overloaded objects as names now won't blow up under threads + [rt.cpan.org 4218 and 4232] + * Overloaded objects which stringify to undef used as test names + now won't cause internal uninit warnings. [rt.cpan.org 4232] + * Failure diagnostics now come out on their own line when run in + Test::Harness. + - eq_set() sometimes wasn't giving the right results if nested refs + were involved [rt.cpan.org 3747] + - isnt() giving wrong diagnostics and warning if given any undefs. + * Give unlike() the right prototype [rt.cpan.org 4944] + - Change from CVS to Aegis + - is_deeply() will now do some basic argument checks to guard against + accidentally passing in a whole array instead of its reference. + - Mentioning Test::Differences, Test::Deep and Bundle::Test. + - Removed dependency on File::Spec. + - Fixing the grammar of diagnostic outputs when only a single test + is run or failed (ie. "Looks like you failed 1 tests"). + [Darren Chamberlain] + +0.48_01 Mon Nov 11 02:36:43 EST 2002 + - Mention Test::Class in Test::More's SEE ALSO + * use_ok() now DWIM for version checks + - More problems with ithreads fixed. + * Test::Harness upgrade no longer optional. It was causing too + many problems when the T::H upgrade didn't work. + * Drew Taylor added a 'no_diag' option to Test::More to switch + off all diag() statements. + * Test::Builder/More no longer automatically loads threads.pm + when threads are enabled. The user must now do this manually. + * Alex Francis added reset() reset the state of Test::Builder in + persistent environments. + - David Hand noted that Test::Builder/More exit code behavior was + not documented. Only Test::Simple. + +0.47 Mon Aug 26 03:54:22 PDT 2002 + * Tatsuhiko Miyagawa noticed Test::Builder was accidentally storing + objects passed into test functions causing problems with tests + relying on object destruction. + - Added example of calculating the number of tests to Test::Tutorial + - Peter Scott made the ending logic not fire on child processes when + forking. + * Test::Builder is once again ithread safe. + +0.46 Sat Jul 20 19:57:40 EDT 2002 + - Noted eq_set() isn't really a set comparision. + - Test fix, exit codes are broken on MacPerl (bleadperl@16868) + - Make Test::Simple install itself into the core for >= 5.8 + - Small fixes to Test::Tutorial and skip examples + * Added TB->has_plan() from Adrian Howard + - Clarified the meaning of 'actual_ok' from TB->details + * Added TB->details() from chromatic + - Neil Watkiss fixed a pre-5.8 test glitch with threads.t + * If the test died before a plan, it would exit with 0 [ID 20020716.013] + +0.45 Wed Jun 19 18:41:12 EDT 2002 + - Andy Lester made the SKIP & TODO docs a bit clearer. + - Explicitly disallowing double plans. (RT #553) + - Kicking up the minimum version of Test::Harness to one that's + fairly bug free. + - Made clear a common problem with use_ok and BEGIN blocks. + - Arthur Bergman made Test::Builder thread-safe. + +0.44 Thu Apr 25 00:27:27 EDT 2002 + - names containing newlines no longer produce confusing output + (from chromatic) + - chromatic provided a fix so can_ok() honors can() overrides. + - Nick Ing-Simmons suggested todo_skip() be a bit clearer about + the skipping part. + - Making plan() vomit if it gets something it doesn't understand. + - Tatsuhiko Miyagawa fixed use_ok() with pragmata on older perls. + - quieting diag(undef) + +0.43 Thu Apr 11 22:55:23 EDT 2002 + - Adrian Howard added TB->maybe_regex() + - Adding Mark Fowler's suggestion to make diag() return + false. + - TB->current_test() still not working when no tests were run via + TB itself. Fixed by Dave Rolsky. + +0.42 Wed Mar 6 15:00:24 EST 2002 + - Setting Test::Builder->current_test() now works (see what happens + when you forget to test things?) + - The change in is()'s undef/'' handling in 0.34 was an API change, + but I forgot to declare it as such. + - The apostrophilic jihad attacks! Philip Newtons patch for + grammar mistakes in the doc's. + +0.41 Mon Dec 17 22:45:20 EST 2001 + * chromatic added diag() + - Internal eval()'s sometimes interfering with $@ and $!. Fixed. + +0.40 Fri Dec 14 15:41:39 EST 2001 + * isa_ok() now accepts unblessed references gracefully + - Nick Clark found a bug with like() and a regex with % in it. + - exit.t was hanging on 5.005_03 VMS perl. Test now skipped. + - can_ok() would pass if no methods were given. Now fails. + - isnt() diagnostic output format changed + * Added some docs about embedding and extending Test::More + * Added Test::More->builder + * Added cmp_ok() + * Added todo_skip() + * Added unlike() + - Piers pointed out that sometimes people override isa(). + isa_ok() now accounts for that. + +0.36 Thu Nov 29 14:07:39 EST 2001 + - Matthias Urlichs found that intermixed prints to STDOUT and test + output came out in the wrong order when piped. + +0.35 Tue Nov 27 19:57:03 EST 2001 + - Little glitch in the test suite. No actual bug. + +0.34 Tue Nov 27 15:43:56 EST 2001 + * **API CHANGE** Empty string no longer matches undef in is() + and isnt(). + * Added isnt_eq and isnt_num to Test::Builder. + +0.33 Mon Oct 22 21:05:47 EDT 2001 + * It's now officially safe to redirect STDOUT and STDERR without + affecting test output. + - License and POD cleanup by Autrijus Tang + - Synched up Test::Tutorial with the wiki version + - Minor VMS test nit. + +0.32 Tue Oct 16 16:52:02 EDT 2001 + * Finally added a seperate plan() function + * Adding a name field to isa_ok() + (Requested by Dave Rolsky) + - Test::More was using Carp.pm, causing the occasional false positive. + (Reported by Tatsuhiko Miyagawa) + +0.31 Mon Oct 8 19:24:53 EDT 2001 + * Added an import option to Test::More + * Added no_ending and no_header options to Test::Builder + (Thanks to Dave Rolsky for giving this a swift kick in the ass) + * Added is_deeply(). Display of scalar refs not quite 100% + (Thanks to Stas Bekman for Apache::TestUtil idea thievery) + - Fixed a minor warning with skip() + (Thanks to Wolfgang Weisselberg for finding this one) + +0.30 Thu Sep 27 22:10:04 EDT 2001 + * Added Test::Builder + (Thanks muchly to chromatic for getting this off the ground!) + * Diagnostics are back to using STDERR *unless* it's from a todo + test. Those go to STDOUT. + - Fixed it so nothing is printed if a test is run with a -c flag. + Handy when a test is being deparsed with B::Deparse. + +0.20 *UNRELEASED* + +0.19 Tue Sep 18 17:48:32 EDT 2001 + * Test::Simple and Test::More no longer print their diagnostics + to STDERR. It instead goes to STDOUT. + * TODO tests which fail now print full failure diagnostics. + - Minor bug in ok()'s test name diagnostics made it think a blank + name was a number. + - ok() less draconian about test names + - Added temporary special case for Parrot::Test + - Now requiring File::Spec for our tests. + +0.18 Wed Sep 5 20:35:24 EDT 2001 + * ***API CHANGE*** can_ok() only counts as one test + - can_ok() has better diagnostics + - Minor POD fixes from mjd + - adjusting the internal layout to make it easier to put it into + the core + +0.17 Wed Aug 29 20:16:28 EDT 2001 + * Added can_ok() and isa_ok() to Test::More + +0.16 Tue Aug 28 19:52:11 EDT 2001 + * vmsperl foiled my sensisble exit codes. Reverting to a much more + coarse scheme. + +0.15 Tue Aug 28 06:18:35 EDT 2001 *UNRELEASED* + * Now using sensible exit codes on VMS. + +0.14 Wed Aug 22 17:26:28 EDT 2001 + * Added a first cut at Test::Tutorial + +0.13 Tue Aug 14 15:30:10 EDT 2001 + * Added a reason to the skip_all interface + - Fixed a bug to allow 'use Test::More;' to work. + (Thanks to Tatsuhiko Miyagawa again) + - Now always testing backwards compatibility. + +0.12 Tue Aug 14 11:02:39 EDT 2001 + * Fixed some compatibility bugs with older Perls + (Thanks to Tatsuhiko Miyagawa) + +0.11 Sat Aug 11 23:05:19 EDT 2001 + * Will no longer warn about testing undef values + - Escaping # in test names + - Ensuring that ok() returns true or false and not undef + - Minor doc typo in the example + +0.10 Tue Jul 31 15:01:11 EDT 2001 + * Test::More is now distributed in this tarball. + * skip and todo tests work! + * Extended use_ok() so it can import + - A little internal rejiggering + - Added a TODO file + +0.09 Wed Jun 27 02:55:54 EDT 2001 + - VMS fixes + +0.08 Fri Jun 15 14:39:50 EDT 2001 + - Guarding against $/ and -l + - Reformatted the way failed tests are reported to make them stand out + a bit better. + +0.07 Tue Jun 12 15:55:54 BST 2001 + - 'use Test::Simple' by itself no longer causes death + - Yet more fixes for death in eval + - Limiting max failures reported via exit code to 254. + +0.06 Wed May 9 23:38:17 BST 2001 + - Whoops, left a private method in the public docs. + +0.05 Wed May 9 20:40:35 BST 2001 + - Forgot to include the exit tests. + - Trouble with exiting properly under 5.005_03 and 5.6.1 fixed + - Turned off buffering + * 5.004 new minimum version + - Now explicitly tested with 5.6.1, 5.6.0, 5.005_03 and 5.004 + +0.04 Mon Apr 2 11:05:01 BST 2001 + - Fixed "require Test::Simple" so it doesn't bitch and exit 255 + - Now installable with the CPAN shell. + +0.03 Fri Mar 30 08:08:33 BST 2001 + - ok() now prints on what line and file it failed. + - eval 'die' was considered abnormal. Fixed. + +0.02 Fri Mar 30 05:12:14 BST 2001 *UNRELEASED* + - exit codes tested + * exit code on abnormal exit changed to 255 (thanks to Tim Bunce for + pointing out that Unix can't do negative exit codes) + - abnormal exits now better caught. + - No longer using Test.pm to test this, but still minimum of 5.005 + due to needing $^S. + +0.01 Wed Mar 28 06:44:44 BST 2001 + - First working version released to CPAN + diff --git a/cpan/Test-Simple/README b/cpan/Test-Simple/README new file mode 100644 index 0000000000..5f825bd41d --- /dev/null +++ b/cpan/Test-Simple/README @@ -0,0 +1,22 @@ +This is the README file for Test::Simple, basic utilities for +writing tests, by Michael G Schwern <schwern@pobox.com>. + +After installation, please consult the tutorial for how to +start adding tests to your modules. 'perldoc Test::Tutorial' +should work on most systems. + +* Installation + +Test::Simple uses the standard perl module install process: + +perl Makefile.PL +make +make test +make install + +It requires Perl version 5.6.0 or newer and Test::Harness 2.03 or newer. + + +* More Info + +More information can be found at http://test-more.googlecode.com/ diff --git a/cpan/Test-Simple/TODO b/cpan/Test-Simple/TODO new file mode 100644 index 0000000000..c596e90876 --- /dev/null +++ b/cpan/Test-Simple/TODO @@ -0,0 +1,18 @@ +See https://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Simple plus here's +a few more I haven't put in RT yet. + + Finish (start?) Test::FAQ + + Expand the Test::Tutorial + + $^C exception control? + + Document that everything goes through Test::Builder->ok() + + Add diag() to details(). + + Add at_end() callback? + + Combine all *output methods into outputs(). + + Change *output* to return the old FH, not the new one when setting. diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm new file mode 100644 index 0000000000..cd5779f75b --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder.pm @@ -0,0 +1,2239 @@ +package Test::Builder; + +use 5.006; +use strict; +use warnings; + +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +BEGIN { + if( $] < 5.008 ) { + require Test::Builder::IO::Scalar; + } +} + + +# Make Test::Builder thread-safe for ithreads. +BEGIN { + use Config; + # Load threads::shared when threads are turned on. + # 5.8.0's threads are so busted we no longer support them. + if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { + require threads::shared; + + # Hack around YET ANOTHER threads::shared bug. It would + # occassionally forget the contents of the variable when sharing it. + # So we first copy the data, then share, then put our copy back. + *share = sub (\[$@%]) { + my $type = ref $_[0]; + my $data; + + if( $type eq 'HASH' ) { + %$data = %{ $_[0] }; + } + elsif( $type eq 'ARRAY' ) { + @$data = @{ $_[0] }; + } + elsif( $type eq 'SCALAR' ) { + $$data = ${ $_[0] }; + } + else { + die( "Unknown type: " . $type ); + } + + $_[0] = &threads::shared::share( $_[0] ); + + if( $type eq 'HASH' ) { + %{ $_[0] } = %$data; + } + elsif( $type eq 'ARRAY' ) { + @{ $_[0] } = @$data; + } + elsif( $type eq 'SCALAR' ) { + ${ $_[0] } = $$data; + } + else { + die( "Unknown type: " . $type ); + } + + return $_[0]; + }; + } + # 5.8.0's threads::shared is busted when threads are off + # and earlier Perls just don't have that module at all. + else { + *share = sub { return $_[0] }; + *lock = sub { 0 }; + } +} + +=head1 NAME + +Test::Builder - Backend for building test libraries + +=head1 SYNOPSIS + + package My::Test::Module; + use base 'Test::Builder::Module'; + + my $CLASS = __PACKAGE__; + + sub ok { + my($test, $name) = @_; + my $tb = $CLASS->builder; + + $tb->ok($test, $name); + } + + +=head1 DESCRIPTION + +Test::Simple and Test::More have proven to be popular testing modules, +but they're not always flexible enough. Test::Builder provides the a +building block upon which to write your own test libraries I<which can +work together>. + +=head2 Construction + +=over 4 + +=item B<new> + + my $Test = Test::Builder->new; + +Returns a Test::Builder object representing the current state of the +test. + +Since you only run one test per program C<new> always returns the same +Test::Builder object. No matter how many times you call C<new()>, you're +getting the same object. This is called a singleton. This is done so that +multiple modules share such global information as the test counter and +where test output is going. + +If you want a completely new Test::Builder object different from the +singleton, use C<create>. + +=cut + +my $Test = Test::Builder->new; + +sub new { + my($class) = shift; + $Test ||= $class->create; + return $Test; +} + +=item B<create> + + my $Test = Test::Builder->create; + +Ok, so there can be more than one Test::Builder object and this is how +you get it. You might use this instead of C<new()> if you're testing +a Test::Builder based module, but otherwise you probably want C<new>. + +B<NOTE>: the implementation is not complete. C<level>, for example, is +still shared amongst B<all> Test::Builder objects, even ones created using +this method. Also, the method name may change in the future. + +=cut + +sub create { + my $class = shift; + + my $self = bless {}, $class; + $self->reset; + + return $self; +} + +=item B<reset> + + $Test->reset; + +Reinitializes the Test::Builder singleton to its original state. +Mostly useful for tests run in persistent environments where the same +test might be run multiple times in the same process. + +=cut + +our $Level; + +sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my($self) = @_; + + # We leave this a global because it has to be localized and localizing + # hash keys is just asking for pain. Also, it was documented. + $Level = 1; + + $self->{Have_Plan} = 0; + $self->{No_Plan} = 0; + $self->{Have_Output_Plan} = 0; + + $self->{Original_Pid} = $$; + + share( $self->{Curr_Test} ); + $self->{Curr_Test} = 0; + $self->{Test_Results} = &share( [] ); + + $self->{Exported_To} = undef; + $self->{Expected_Tests} = 0; + + $self->{Skip_All} = 0; + + $self->{Use_Nums} = 1; + + $self->{No_Header} = 0; + $self->{No_Ending} = 0; + + $self->{Todo} = undef; + $self->{Todo_Stack} = []; + $self->{Start_Todo} = 0; + $self->{Opened_Testhandles} = 0; + + $self->_dup_stdhandles; + + return; +} + +=back + +=head2 Setting up tests + +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. + +=over 4 + +=item B<plan> + + $Test->plan('no_plan'); + $Test->plan( skip_all => $reason ); + $Test->plan( tests => $num_tests ); + +A convenient way to set up your tests. Call this and Test::Builder +will print the appropriate headers and take the appropriate actions. + +If you call C<plan()>, don't call any of the other methods below. + +=cut + +my %plan_cmds = ( + no_plan => \&no_plan, + skip_all => \&skip_all, + tests => \&_plan_tests, +); + +sub plan { + my( $self, $cmd, $arg ) = @_; + + return unless $cmd; + + local $Level = $Level + 1; + + $self->croak("You tried to plan twice") if $self->{Have_Plan}; + + if( my $method = $plan_cmds{$cmd} ) { + local $Level = $Level + 1; + $self->$method($arg); + } + else { + my @args = grep { defined } ( $cmd, $arg ); + $self->croak("plan() doesn't understand @args"); + } + + return 1; +} + + +sub _plan_tests { + my($self, $arg) = @_; + + if($arg) { + local $Level = $Level + 1; + return $self->expected_tests($arg); + } + elsif( !defined $arg ) { + $self->croak("Got an undefined number of tests"); + } + else { + $self->croak("You said to run 0 tests"); + } + + return; +} + + +=item B<expected_tests> + + my $max = $Test->expected_tests; + $Test->expected_tests($max); + +Gets/sets the number of tests we expect this test to run and prints out +the appropriate headers. + +=cut + +sub expected_tests { + my $self = shift; + my($max) = @_; + + if(@_) { + $self->croak("Number of tests must be a positive integer. You gave it '$max'") + unless $max =~ /^\+?\d+$/; + + $self->{Expected_Tests} = $max; + $self->{Have_Plan} = 1; + + $self->_output_plan($max) unless $self->no_header; + } + return $self->{Expected_Tests}; +} + +=item B<no_plan> + + $Test->no_plan; + +Declares that this test will run an indeterminate number of tests. + +=cut + +sub no_plan { + my($self, $arg) = @_; + + $self->carp("no_plan takes no arguments") if $arg; + + $self->{No_Plan} = 1; + $self->{Have_Plan} = 1; + + return 1; +} + + +=begin private + +=item B<_output_plan> + + $tb->_output_plan($max); + $tb->_output_plan($max, $directive); + $tb->_output_plan($max, $directive => $reason); + +Handles displaying the test plan. + +If a C<$directive> and/or C<$reason> are given they will be output with the +plan. So here's what skipping all tests looks like: + + $tb->_output_plan(0, "SKIP", "Because I said so"); + +It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already +output. + +=end private + +=cut + +sub _output_plan { + my($self, $max, $directive, $reason) = @_; + + $self->carp("The plan was already output") if $self->{Have_Output_Plan}; + + my $plan = "1..$max"; + $plan .= " # $directive" if defined $directive; + $plan .= " $reason" if defined $reason; + + $self->_print("$plan\n"); + + $self->{Have_Output_Plan} = 1; + + return; +} + +=item B<done_testing> + + $Test->done_testing(); + $Test->done_testing($num_tests); + +Declares that you are done testing, no more tests will be run after this point. + +If a plan has not yet been output, it will do so. + +$num_tests is the number of tests you planned to run. If a numbered +plan was already declared, and if this contradicts, a failing test +will be run to reflect the planning mistake. If C<no_plan> was declared, +this will override. + +If C<done_testing()> is called twice, the second call will issue a +failing test. + +If C<$num_tests> is omitted, the number of tests run will be used, like +no_plan. + +C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but +safer. You'd use it like so: + + $Test->ok($a == $b); + $Test->done_testing(); + +Or to plan a variable number of tests: + + for my $test (@tests) { + $Test->ok($test); + } + $Test->done_testing(@tests); + +=cut + +sub done_testing { + my($self, $num_tests) = @_; + + # If done_testing() specified the number of tests, shut off no_plan. + if( defined $num_tests ) { + $self->{No_Plan} = 0; + } + else { + $num_tests = $self->current_test; + } + + if( $self->{Done_Testing} ) { + my($file, $line) = @{$self->{Done_Testing}}[1,2]; + $self->ok(0, "done_testing() was already called at $file line $line"); + return; + } + + $self->{Done_Testing} = [caller]; + + if( $self->expected_tests && $num_tests != $self->expected_tests ) { + $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". + "but done_testing() expects $num_tests"); + } + else { + $self->{Expected_Tests} = $num_tests; + } + + $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; + + $self->{Have_Plan} = 1; + + return 1; +} + + +=item B<has_plan> + + $plan = $Test->has_plan + +Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan +has been set), C<no_plan> (indeterminate # of tests) or an integer (the number +of expected tests). + +=cut + +sub has_plan { + my $self = shift; + + return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; + return('no_plan') if $self->{No_Plan}; + return(undef); +} + +=item B<skip_all> + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given C<$reason>. Exits immediately with 0. + +=cut + +sub skip_all { + my( $self, $reason ) = @_; + + $self->{Skip_All} = 1; + + $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; + exit(0); +} + +=item B<exported_to> + + my $pack = $Test->exported_to; + $Test->exported_to($pack); + +Tells Test::Builder what package you exported your functions to. + +This method isn't terribly useful since modules which share the same +Test::Builder object might get exported to different packages and only +the last one will be honored. + +=cut + +sub exported_to { + my( $self, $pack ) = @_; + + if( defined $pack ) { + $self->{Exported_To} = $pack; + } + return $self->{Exported_To}; +} + +=back + +=head2 Running tests + +These actually run the tests, analogous to the functions in Test::More. + +They all return true if the test passed, false if the test failed. + +C<$name> is always optional. + +=over 4 + +=item B<ok> + + $Test->ok($test, $name); + +Your basic test. Pass if C<$test> is true, fail if $test is false. Just +like Test::Simple's C<ok()>. + +=cut + +sub ok { + my( $self, $test, $name ) = @_; + + # $test might contain an object which we don't want to accidentally + # store, so we turn it into a boolean. + $test = $test ? 1 : 0; + + lock $self->{Curr_Test}; + $self->{Curr_Test}++; + + # In case $name is a string overloaded object, force it to stringify. + $self->_unoverload_str( \$name ); + + $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; + You named your test '$name'. You shouldn't use numbers for your test names. + Very confusing. +ERR + + # Capture the value of $TODO for the rest of this ok() call + # so it can more easily be found by other routines. + my $todo = $self->todo(); + my $in_todo = $self->in_todo; + local $self->{Todo} = $todo if $in_todo; + + $self->_unoverload_str( \$todo ); + + my $out; + my $result = &share( {} ); + + unless($test) { + $out .= "not "; + @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); + } + else { + @$result{ 'ok', 'actual_ok' } = ( 1, $test ); + } + + $out .= "ok"; + $out .= " $self->{Curr_Test}" if $self->use_numbers; + + if( defined $name ) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $out .= " - $name"; + $result->{name} = $name; + } + else { + $result->{name} = ''; + } + + if( $self->in_todo ) { + $out .= " # TODO $todo"; + $result->{reason} = $todo; + $result->{type} = 'todo'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } + + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; + $out .= "\n"; + + $self->_print($out); + + unless($test) { + my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; + $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; + + my( undef, $file, $line ) = $self->caller; + if( defined $name ) { + $self->diag(qq[ $msg test '$name'\n]); + $self->diag(qq[ at $file line $line.\n]); + } + else { + $self->diag(qq[ $msg test at $file line $line.\n]); + } + } + + return $test ? 1 : 0; +} + +sub _unoverload { + my $self = shift; + my $type = shift; + + $self->_try(sub { require overload; }, die_on_fail => 1); + + foreach my $thing (@_) { + if( $self->_is_object($$thing) ) { + if( my $string_meth = overload::Method( $$thing, $type ) ) { + $$thing = $$thing->$string_meth(); + } + } + } + + return; +} + +sub _is_object { + my( $self, $thing ) = @_; + + return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; +} + +sub _unoverload_str { + my $self = shift; + + return $self->_unoverload( q[""], @_ ); +} + +sub _unoverload_num { + my $self = shift; + + $self->_unoverload( '0+', @_ ); + + for my $val (@_) { + next unless $self->_is_dualvar($$val); + $$val = $$val + 0; + } + + return; +} + +# This is a hack to detect a dualvar such as $! +sub _is_dualvar { + my( $self, $val ) = @_; + + # Objects are not dualvars. + return 0 if ref $val; + + no warnings 'numeric'; + my $numval = $val + 0; + return $numval != 0 and $numval ne $val ? 1 : 0; +} + +=item B<is_eq> + + $Test->is_eq($got, $expected, $name); + +Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the +string version. + +=item B<is_num> + + $Test->is_num($got, $expected, $name); + +Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the +numeric version. + +=cut + +sub is_eq { + my( $self, $got, $expect, $name ) = @_; + local $Level = $Level + 1; + + $self->_unoverload_str( \$got, \$expect ); + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok( $test, $name ); + $self->_is_diag( $got, 'eq', $expect ) unless $test; + return $test; + } + + return $self->cmp_ok( $got, 'eq', $expect, $name ); +} + +sub is_num { + my( $self, $got, $expect, $name ) = @_; + local $Level = $Level + 1; + + $self->_unoverload_num( \$got, \$expect ); + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok( $test, $name ); + $self->_is_diag( $got, '==', $expect ) unless $test; + return $test; + } + + return $self->cmp_ok( $got, '==', $expect, $name ); +} + +sub _diag_fmt { + my( $self, $type, $val ) = @_; + + if( defined $$val ) { + if( $type eq 'eq' or $type eq 'ne' ) { + # quote and force string context + $$val = "'$$val'"; + } + else { + # force numeric context + $self->_unoverload_num($val); + } + } + else { + $$val = 'undef'; + } + + return; +} + +sub _is_diag { + my( $self, $got, $type, $expect ) = @_; + + $self->_diag_fmt( $type, $_ ) for \$got, \$expect; + + local $Level = $Level + 1; + return $self->diag(<<"DIAGNOSTIC"); + got: $got + expected: $expect +DIAGNOSTIC + +} + +sub _isnt_diag { + my( $self, $got, $type ) = @_; + + $self->_diag_fmt( $type, \$got ); + + local $Level = $Level + 1; + return $self->diag(<<"DIAGNOSTIC"); + got: $got + expected: anything else +DIAGNOSTIC +} + +=item B<isnt_eq> + + $Test->isnt_eq($got, $dont_expect, $name); + +Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is +the string version. + +=item B<isnt_num> + + $Test->isnt_num($got, $dont_expect, $name); + +Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is +the numeric version. + +=cut + +sub isnt_eq { + my( $self, $got, $dont_expect, $name ) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok( $test, $name ); + $self->_isnt_diag( $got, 'ne' ) unless $test; + return $test; + } + + return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); +} + +sub isnt_num { + my( $self, $got, $dont_expect, $name ) = @_; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok( $test, $name ); + $self->_isnt_diag( $got, '!=' ) unless $test; + return $test; + } + + return $self->cmp_ok( $got, '!=', $dont_expect, $name ); +} + +=item B<like> + + $Test->like($this, qr/$regex/, $name); + $Test->like($this, '/$regex/', $name); + +Like Test::More's C<like()>. Checks if $this matches the given C<$regex>. + +You'll want to avoid C<qr//> if you want your tests to work before 5.005. + +=item B<unlike> + + $Test->unlike($this, qr/$regex/, $name); + $Test->unlike($this, '/$regex/', $name); + +Like Test::More's C<unlike()>. Checks if $this B<does not match> the +given C<$regex>. + +=cut + +sub like { + my( $self, $this, $regex, $name ) = @_; + + local $Level = $Level + 1; + return $self->_regex_ok( $this, $regex, '=~', $name ); +} + +sub unlike { + my( $self, $this, $regex, $name ) = @_; + + local $Level = $Level + 1; + return $self->_regex_ok( $this, $regex, '!~', $name ); +} + +=item B<cmp_ok> + + $Test->cmp_ok($this, $type, $that, $name); + +Works just like Test::More's C<cmp_ok()>. + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=cut + +my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); + +sub cmp_ok { + my( $self, $got, $type, $expect, $name ) = @_; + + my $test; + my $error; + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + my($pack, $file, $line) = $self->caller(); + + $test = eval qq[ +#line 1 "cmp_ok [from $file line $line]" +\$got $type \$expect; +]; + $error = $@; + } + local $Level = $Level + 1; + my $ok = $self->ok( $test, $name ); + + # Treat overloaded objects as numbers if we're asked to do a + # numeric comparison. + my $unoverload + = $numeric_cmps{$type} + ? '_unoverload_num' + : '_unoverload_str'; + + $self->diag(<<"END") if $error; +An error occurred while using $type: +------------------------------------ +$error +------------------------------------ +END + + unless($ok) { + $self->$unoverload( \$got, \$expect ); + + if( $type =~ /^(eq|==)$/ ) { + $self->_is_diag( $got, $type, $expect ); + } + elsif( $type =~ /^(ne|!=)$/ ) { + $self->_isnt_diag( $got, $type ); + } + else { + $self->_cmp_diag( $got, $type, $expect ); + } + } + return $ok; +} + +sub _cmp_diag { + my( $self, $got, $type, $expect ) = @_; + + $got = defined $got ? "'$got'" : 'undef'; + $expect = defined $expect ? "'$expect'" : 'undef'; + + local $Level = $Level + 1; + return $self->diag(<<"DIAGNOSTIC"); + $got + $type + $expect +DIAGNOSTIC +} + +sub _caller_context { + my $self = shift; + + my( $pack, $file, $line ) = $self->caller(1); + + my $code = ''; + $code .= "#line $line $file\n" if defined $file and defined $line; + + return $code; +} + +=back + + +=head2 Other Testing Methods + +These are methods which are used in the course of writing a test but are not themselves tests. + +=over 4 + +=item B<BAIL_OUT> + + $Test->BAIL_OUT($reason); + +Indicates to the Test::Harness that things are going so badly all +testing should terminate. This includes running any additional test +scripts. + +It will exit with 255. + +=cut + +sub BAIL_OUT { + my( $self, $reason ) = @_; + + $self->{Bailed_Out} = 1; + $self->_print("Bail out! $reason"); + exit 255; +} + +=for deprecated +BAIL_OUT() used to be BAILOUT() + +=cut + +*BAILOUT = \&BAIL_OUT; + +=item B<skip> + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting C<$why>. + +=cut + +sub skip { + my( $self, $why ) = @_; + $why ||= ''; + $self->_unoverload_str( \$why ); + + lock( $self->{Curr_Test} ); + $self->{Curr_Test}++; + + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( + { + 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => $why, + } + ); + + my $out = "ok"; + $out .= " $self->{Curr_Test}" if $self->use_numbers; + $out .= " # skip"; + $out .= " $why" if length $why; + $out .= "\n"; + + $self->_print($out); + + return 1; +} + +=item B<todo_skip> + + $Test->todo_skip; + $Test->todo_skip($why); + +Like C<skip()>, only it will declare the test as failing and TODO. Similar +to + + print "not ok $tnum # TODO $why\n"; + +=cut + +sub todo_skip { + my( $self, $why ) = @_; + $why ||= ''; + + lock( $self->{Curr_Test} ); + $self->{Curr_Test}++; + + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( + { + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + } + ); + + my $out = "not ok"; + $out .= " $self->{Curr_Test}" if $self->use_numbers; + $out .= " # TODO & SKIP $why\n"; + + $self->_print($out); + + return 1; +} + +=begin _unimplemented + +=item B<skip_rest> + + $Test->skip_rest; + $Test->skip_rest($reason); + +Like C<skip()>, only it skips all the rest of the tests you plan to run +and terminates the test. + +If you're running under C<no_plan>, it skips once and terminates the +test. + +=end _unimplemented + +=back + + +=head2 Test building utility methods + +These methods are useful when writing your own test methods. + +=over 4 + +=item B<maybe_regex> + + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); + +Convenience method for building testing functions that take regular +expressions as arguments, but need to work before perl 5.005. + +Takes a quoted regular expression produced by C<qr//>, or a string +representing a regular expression. + +Returns a Perl value which may be used instead of the corresponding +regular expression, or C<undef> if its argument is not recognised. + +For example, a version of C<like()>, sans the useful diagnostic messages, +could be written as: + + sub laconic_like { + my ($self, $this, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($this =~ m/$usable_regex/, $name); + } + +=cut + +sub maybe_regex { + my( $self, $regex ) = @_; + my $usable_regex = undef; + + return $usable_regex unless defined $regex; + + my( $re, $opts ); + + # Check for qr/foo/ + if( _is_qr($regex) ) { + $usable_regex = $regex; + } + # Check for '/foo/' or 'm,foo,' + elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or + ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx + ) + { + $usable_regex = length $opts ? "(?$opts)$re" : $re; + } + + return $usable_regex; +} + +sub _is_qr { + my $regex = shift; + + # is_regexp() checks for regexes in a robust manner, say if they're + # blessed. + return re::is_regexp($regex) if defined &re::is_regexp; + return ref $regex eq 'Regexp'; +} + +sub _regex_ok { + my( $self, $this, $regex, $cmp, $name ) = @_; + + my $ok = 0; + my $usable_regex = $self->maybe_regex($regex); + unless( defined $usable_regex ) { + local $Level = $Level + 1; + $ok = $self->ok( 0, $name ); + $self->diag(" '$regex' doesn't look much like a regex to me."); + return $ok; + } + + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + my $test; + my $code = $self->_caller_context; + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + # Yes, it has to look like this or 5.4.5 won't see the #line + # directive. + # Don't ask me, man, I just work here. + $test = eval " +$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; + + $test = !$test if $cmp eq '!~'; + + local $Level = $Level + 1; + $ok = $self->ok( $test, $name ); + } + + unless($ok) { + $this = defined $this ? "'$this'" : 'undef'; + my $match = $cmp eq '=~' ? "doesn't match" : "matches"; + + local $Level = $Level + 1; + $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); + %s + %13s '%s' +DIAGNOSTIC + + } + + return $ok; +} + +# I'm not ready to publish this. It doesn't deal with array return +# values from the code or context. + +=begin private + +=item B<_try> + + my $return_from_code = $Test->try(sub { code }); + my($return_from_code, $error) = $Test->try(sub { code }); + +Works like eval BLOCK except it ensures it has no effect on the rest +of the test (ie. C<$@> is not set) nor is effected by outside +interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older +Perls. + +C<$error> is what would normally be in C<$@>. + +It is suggested you use this in place of eval BLOCK. + +=cut + +sub _try { + my( $self, $code, %opts ) = @_; + + my $error; + my $return; + { + local $!; # eval can mess up $! + local $@; # don't set $@ in the test + local $SIG{__DIE__}; # don't trip an outside DIE handler. + $return = eval { $code->() }; + $error = $@; + } + + die $error if $error and $opts{die_on_fail}; + + return wantarray ? ( $return, $error ) : $return; +} + +=end private + + +=item B<is_fh> + + my $is_fh = $Test->is_fh($thing); + +Determines if the given C<$thing> can be used as a filehandle. + +=cut + +sub is_fh { + my $self = shift; + my $maybe_fh = shift; + return 0 unless defined $maybe_fh; + + return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob + + return eval { $maybe_fh->isa("IO::Handle") } || + # 5.5.4's tied() and can() doesn't like getting undef + eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') }; +} + +=back + + +=head2 Test style + + +=over 4 + +=item B<level> + + $Test->level($how_high); + +How far up the call stack should C<$Test> look when reporting where the +test failed. + +Defaults to 1. + +Setting L<$Test::Builder::Level> overrides. This is typically useful +localized: + + sub my_ok { + my $test = shift; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + $TB->ok($test); + } + +To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. + +=cut + +sub level { + my( $self, $level ) = @_; + + if( defined $level ) { + $Level = $level; + } + return $Level; +} + +=item B<use_numbers> + + $Test->use_numbers($on_or_off); + +Whether or not the test should output numbers. That is, this if true: + + ok 1 + ok 2 + ok 3 + +or this if false + + ok + ok + ok + +Most useful when you can't depend on the test output order, such as +when threads or forking is involved. + +Defaults to on. + +=cut + +sub use_numbers { + my( $self, $use_nums ) = @_; + + if( defined $use_nums ) { + $self->{Use_Nums} = $use_nums; + } + return $self->{Use_Nums}; +} + +=item B<no_diag> + + $Test->no_diag($no_diag); + +If set true no diagnostics will be printed. This includes calls to +C<diag()>. + +=item B<no_ending> + + $Test->no_ending($no_ending); + +Normally, Test::Builder does some extra diagnostics when the test +ends. It also changes the exit code as described below. + +If this is true, none of that will be done. + +=item B<no_header> + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + +=cut + +foreach my $attribute (qw(No_Header No_Ending No_Diag)) { + my $method = lc $attribute; + + my $code = sub { + my( $self, $no ) = @_; + + if( defined $no ) { + $self->{$attribute} = $no; + } + return $self->{$attribute}; + }; + + no strict 'refs'; ## no critic + *{ __PACKAGE__ . '::' . $method } = $code; +} + +=back + +=head2 Output + +Controlling where the test output goes. + +It's ok for your test to change where STDOUT and STDERR point to, +Test::Builder's default output settings will not be affected. + +=over 4 + +=item B<diag> + + $Test->diag(@msgs); + +Prints out the given C<@msgs>. Like C<print>, arguments are simply +appended together. + +Normally, it uses the C<failure_output()> handle, but if this is for a +TODO test, the C<todo_output()> handle is used. + +Output will be indented and marked with a # so as not to interfere +with test output. A newline will be put on the end if there isn't one +already. + +We encourage using this rather than calling print directly. + +Returns false. Why? Because C<diag()> is often used in conjunction with +a failing test (C<ok() || diag()>) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler <mark@twoshortplanks.com> + +=cut + +sub diag { + my $self = shift; + + $self->_print_comment( $self->_diag_fh, @_ ); +} + +=item B<note> + + $Test->note(@msgs); + +Like C<diag()>, but it prints to the C<output()> handle so it will not +normally be seen by the user except in verbose mode. + +=cut + +sub note { + my $self = shift; + + $self->_print_comment( $self->output, @_ ); +} + +sub _diag_fh { + my $self = shift; + + local $Level = $Level + 1; + return $self->in_todo ? $self->todo_output : $self->failure_output; +} + +sub _print_comment { + my( $self, $fh, @msgs ) = @_; + + return if $self->no_diag; + return unless @msgs; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + # Smash args together like print does. + # Convert undef to 'undef' so its readable. + my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; + + # Escape the beginning, _print will take care of the rest. + $msg =~ s/^/# /; + + local $Level = $Level + 1; + $self->_print_to_fh( $fh, $msg ); + + return 0; +} + +=item B<explain> + + my @dump = $Test->explain(@msgs); + +Will dump the contents of any references in a human readable format. +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + is_deeply($have, $want) || note explain $have; + +=cut + +sub explain { + my $self = shift; + + return map { + ref $_ + ? do { + $self->_try(sub { require Data::Dumper }, die_on_fail => 1); + + my $dumper = Data::Dumper->new( [$_] ); + $dumper->Indent(1)->Terse(1); + $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); + $dumper->Dump; + } + : $_ + } @_; +} + +=begin _private + +=item B<_print> + + $Test->_print(@msgs); + +Prints to the C<output()> filehandle. + +=end _private + +=cut + +sub _print { + my $self = shift; + return $self->_print_to_fh( $self->output, @_ ); +} + +sub _print_to_fh { + my( $self, $fh, @msgs ) = @_; + + # Prevent printing headers when only compiling. Mostly for when + # tests are deparsed with B::Deparse + return if $^C; + + my $msg = join '', @msgs; + + local( $\, $", $, ) = ( undef, ' ', '' ); + + # Escape each line after the first with a # so we don't + # confuse Test::Harness. + $msg =~ s{\n(?!\z)}{\n# }sg; + + # Stick a newline on the end if it needs it. + $msg .= "\n" unless $msg =~ /\n\z/; + + return print $fh $msg; +} + +=item B<output> + +=item B<failure_output> + +=item B<todo_output> + + my $filehandle = $Test->output; + $Test->output($filehandle); + $Test->output($filename); + $Test->output(\$scalar); + +These methods control where Test::Builder will print its output. +They take either an open C<$filehandle>, a C<$filename> to open and write to +or a C<$scalar> reference to append to. It will always return a C<$filehandle>. + +B<output> is where normal "ok/not ok" test output goes. + +Defaults to STDOUT. + +B<failure_output> is where diagnostic output on test failures and +C<diag()> goes. It is normally not read by Test::Harness and instead is +displayed to the user. + +Defaults to STDERR. + +C<todo_output> is used instead of C<failure_output()> for the +diagnostics of a failing TODO test. These will not be seen by the +user. + +Defaults to STDOUT. + +=cut + +sub output { + my( $self, $fh ) = @_; + + if( defined $fh ) { + $self->{Out_FH} = $self->_new_fh($fh); + } + return $self->{Out_FH}; +} + +sub failure_output { + my( $self, $fh ) = @_; + + if( defined $fh ) { + $self->{Fail_FH} = $self->_new_fh($fh); + } + return $self->{Fail_FH}; +} + +sub todo_output { + my( $self, $fh ) = @_; + + if( defined $fh ) { + $self->{Todo_FH} = $self->_new_fh($fh); + } + return $self->{Todo_FH}; +} + +sub _new_fh { + my $self = shift; + my($file_or_fh) = shift; + + my $fh; + if( $self->is_fh($file_or_fh) ) { + $fh = $file_or_fh; + } + elsif( ref $file_or_fh eq 'SCALAR' ) { + # Scalar refs as filehandles was added in 5.8. + if( $] >= 5.008 ) { + open $fh, ">>", $file_or_fh + or $self->croak("Can't open scalar ref $file_or_fh: $!"); + } + # Emulate scalar ref filehandles with a tie. + else { + $fh = Test::Builder::IO::Scalar->new($file_or_fh) + or $self->croak("Can't tie scalar ref $file_or_fh"); + } + } + else { + open $fh, ">", $file_or_fh + or $self->croak("Can't open test output log $file_or_fh: $!"); + _autoflush($fh); + } + + return $fh; +} + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; + + return; +} + +my( $Testout, $Testerr ); + +sub _dup_stdhandles { + my $self = shift; + + $self->_open_testhandles; + + # Set everything to unbuffered else plain prints to STDOUT will + # come out in the wrong order from our own prints. + _autoflush($Testout); + _autoflush( \*STDOUT ); + _autoflush($Testerr); + _autoflush( \*STDERR ); + + $self->reset_outputs; + + return; +} + +sub _open_testhandles { + my $self = shift; + + return if $self->{Opened_Testhandles}; + + # We dup STDOUT and STDERR so people can change them in their + # test suites while still getting normal test output. + open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; + open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; + + # $self->_copy_io_layers( \*STDOUT, $Testout ); + # $self->_copy_io_layers( \*STDERR, $Testerr ); + + $self->{Opened_Testhandles} = 1; + + return; +} + +sub _copy_io_layers { + my( $self, $src, $dst ) = @_; + + $self->_try( + sub { + require PerlIO; + my @src_layers = PerlIO::get_layers($src); + + binmode $dst, join " ", map ":$_", @src_layers if @src_layers; + } + ); + + return; +} + +=item reset_outputs + + $tb->reset_outputs; + +Resets all the output filehandles back to their defaults. + +=cut + +sub reset_outputs { + my $self = shift; + + $self->output ($Testout); + $self->failure_output($Testerr); + $self->todo_output ($Testout); + + return; +} + +=item carp + + $tb->carp(@message); + +Warns with C<@message> but the message will appear to come from the +point where the original test function was called (C<< $tb->caller >>). + +=item croak + + $tb->croak(@message); + +Dies with C<@message> but the message will appear to come from the +point where the original test function was called (C<< $tb->caller >>). + +=cut + +sub _message_at_caller { + my $self = shift; + + local $Level = $Level + 1; + my( $pack, $file, $line ) = $self->caller; + return join( "", @_ ) . " at $file line $line.\n"; +} + +sub carp { + my $self = shift; + return warn $self->_message_at_caller(@_); +} + +sub croak { + my $self = shift; + return die $self->_message_at_caller(@_); +} + + +=back + + +=head2 Test Status and Info + +=over 4 + +=item B<current_test> + + my $curr_test = $Test->current_test; + $Test->current_test($num); + +Gets/sets the current test number we're on. You usually shouldn't +have to set this. + +If set forward, the details of the missing tests are filled in as 'unknown'. +if set backward, the details of the intervening tests are deleted. You +can erase history if you really want to. + +=cut + +sub current_test { + my( $self, $num ) = @_; + + lock( $self->{Curr_Test} ); + if( defined $num ) { + $self->{Curr_Test} = $num; + + # If the test counter is being pushed forward fill in the details. + my $test_results = $self->{Test_Results}; + if( $num > @$test_results ) { + my $start = @$test_results ? @$test_results : 0; + for( $start .. $num - 1 ) { + $test_results->[$_] = &share( + { + 'ok' => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + } + ); + } + } + # If backward, wipe history. Its their funeral. + elsif( $num < @$test_results ) { + $#{$test_results} = $num - 1; + } + } + return $self->{Curr_Test}; +} + +=item B<summary> + + my @tests = $Test->summary; + +A simple summary of the tests so far. True for pass, false for fail. +This is a logical pass/fail, so todos are passes. + +Of course, test #1 is $tests[0], etc... + +=cut + +sub summary { + my($self) = shift; + + return map { $_->{'ok'} } @{ $self->{Test_Results} }; +} + +=item B<details> + + my @tests = $Test->details; + +Like C<summary()>, but with a lot more detail. + + $tests[$test_num - 1] = + { 'ok' => is the test considered a pass? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + type => type of test (if any, see below). + reason => reason for the above (if any) + }; + +'ok' is true if Test::Harness will consider the test to be a pass. + +'actual_ok' is a reflection of whether or not the test literally +printed 'ok' or 'not ok'. This is for examining the result of 'todo' +tests. + +'name' is the name of the test. + +'type' indicates if it was a special test. Normal tests have a type +of ''. Type can be one of the following: + + skip see skip() + todo see todo() + todo_skip see todo_skip() + unknown see below + +Sometimes the Test::Builder test counter is incremented without it +printing any test output, for example, when C<current_test()> is changed. +In these cases, Test::Builder doesn't know the result of the test, so +its type is 'unknown'. These details for these tests are filled in. +They are considered ok, but the name and actual_ok is left C<undef>. + +For example "not ok 23 - hole count # TODO insufficient donuts" would +result in this structure: + + $tests[22] = # 23 - 1, since arrays start from 0. + { ok => 1, # logically, the test passed since its todo + actual_ok => 0, # in absolute terms, it failed + name => 'hole count', + type => 'todo', + reason => 'insufficient donuts' + }; + +=cut + +sub details { + my $self = shift; + return @{ $self->{Test_Results} }; +} + +=item B<todo> + + my $todo_reason = $Test->todo; + my $todo_reason = $Test->todo($pack); + +If the current tests are considered "TODO" it will return the reason, +if any. This reason can come from a C<$TODO> variable or the last call +to C<todo_start()>. + +Since a TODO test does not need a reason, this function can return an +empty string even when inside a TODO block. Use C<< $Test->in_todo >> +to determine if you are currently inside a TODO block. + +C<todo()> is about finding the right package to look for C<$TODO> in. It's +pretty good at guessing the right package to look at. It first looks for +the caller based on C<$Level + 1>, since C<todo()> is usually called inside +a test function. As a last resort it will use C<exported_to()>. + +Sometimes there is some confusion about where todo() should be looking +for the C<$TODO> variable. If you want to be sure, tell it explicitly +what $pack to use. + +=cut + +sub todo { + my( $self, $pack ) = @_; + + return $self->{Todo} if defined $self->{Todo}; + + local $Level = $Level + 1; + my $todo = $self->find_TODO($pack); + return $todo if defined $todo; + + return ''; +} + +=item B<find_TODO> + + my $todo_reason = $Test->find_TODO(); + my $todo_reason = $Test->find_TODO($pack): + +Like C<todo()> but only returns the value of C<$TODO> ignoring +C<todo_start()>. + +=cut + +sub find_TODO { + my( $self, $pack ) = @_; + + $pack = $pack || $self->caller(1) || $self->exported_to; + return unless $pack; + + no strict 'refs'; ## no critic + return ${ $pack . '::TODO' }; +} + +=item B<in_todo> + + my $in_todo = $Test->in_todo; + +Returns true if the test is currently inside a TODO block. + +=cut + +sub in_todo { + my $self = shift; + + local $Level = $Level + 1; + return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; +} + +=item B<todo_start> + + $Test->todo_start(); + $Test->todo_start($message); + +This method allows you declare all subsequent tests as TODO tests, up until +the C<todo_end> method has been called. + +The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out +whether or not we're in a TODO test. However, often we find that this is not +possible to determine (such as when we want to use C<$TODO> but +the tests are being executed in other packages which can't be inferred +beforehand). + +Note that you can use this to nest "todo" tests + + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + +This is generally not recommended, but large testing systems often have weird +internal needs. + +We've tried to make this also work with the TODO: syntax, but it's not +guaranteed and its use is also discouraged: + + TODO: { + local $TODO = 'We have work to do!'; + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + } + +Pick one style or another of "TODO" to be on the safe side. + +=cut + +sub todo_start { + my $self = shift; + my $message = @_ ? shift : ''; + + $self->{Start_Todo}++; + if( $self->in_todo ) { + push @{ $self->{Todo_Stack} } => $self->todo; + } + $self->{Todo} = $message; + + return; +} + +=item C<todo_end> + + $Test->todo_end; + +Stops running tests as "TODO" tests. This method is fatal if called without a +preceding C<todo_start> method call. + +=cut + +sub todo_end { + my $self = shift; + + if( !$self->{Start_Todo} ) { + $self->croak('todo_end() called without todo_start()'); + } + + $self->{Start_Todo}--; + + if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { + $self->{Todo} = pop @{ $self->{Todo_Stack} }; + } + else { + delete $self->{Todo}; + } + + return; +} + +=item B<caller> + + my $package = $Test->caller; + my($pack, $file, $line) = $Test->caller; + my($pack, $file, $line) = $Test->caller($height); + +Like the normal C<caller()>, except it reports according to your C<level()>. + +C<$height> will be added to the C<level()>. + +If C<caller()> winds up off the top of the stack it report the highest context. + +=cut + +sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my( $self, $height ) = @_; + $height ||= 0; + + my $level = $self->level + $height + 1; + my @caller; + do { + @caller = CORE::caller( $level ); + $level--; + } until @caller; + return wantarray ? @caller : $caller[0]; +} + +=back + +=cut + +=begin _private + +=over 4 + +=item B<_sanity_check> + + $self->_sanity_check(); + +Runs a bunch of end of test sanity checks to make sure reality came +through ok. If anything is wrong it will die with a fairly friendly +error message. + +=cut + +#'# +sub _sanity_check { + my $self = shift; + + $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); + $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, + 'Somehow you got a different number of results than tests ran!' ); + + return; +} + +=item B<_whoa> + + $self->_whoa($check, $description); + +A sanity check, similar to C<assert()>. If the C<$check> is true, something +has gone horribly wrong. It will die with the given C<$description> and +a note to contact the author. + +=cut + +sub _whoa { + my( $self, $check, $desc ) = @_; + if($check) { + local $Level = $Level + 1; + $self->croak(<<"WHOA"); +WHOA! $desc +This should never happen! Please contact the author immediately! +WHOA + } + + return; +} + +=item B<_my_exit> + + _my_exit($exit_num); + +Perl seems to have some trouble with exiting inside an C<END> block. 5.005_03 +and 5.6.1 both seem to do odd things. Instead, this function edits C<$?> +directly. It should B<only> be called from inside an C<END> block. It +doesn't actually exit, that's your job. + +=cut + +sub _my_exit { + $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) + + return 1; +} + +=back + +=end _private + +=cut + +sub _ending { + my $self = shift; + + my $real_exit_code = $?; + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + if( $self->{Original_Pid} != $$ ) { + return; + } + + # Ran tests but never declared a plan or hit done_testing + if( !$self->{Have_Plan} and $self->{Curr_Test} ) { + $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); + } + + # Exit if plan() was never called. This is so "require Test::Simple" + # doesn't puke. + if( !$self->{Have_Plan} ) { + return; + } + + # Don't do an ending if we bailed out. + if( $self->{Bailed_Out} ) { + return; + } + + # Figure out if we passed or failed and print helpful messages. + my $test_results = $self->{Test_Results}; + if(@$test_results) { + # The plan? We have no plan. + if( $self->{No_Plan} ) { + $self->_output_plan($self->{Curr_Test}) unless $self->no_header; + $self->{Expected_Tests} = $self->{Curr_Test}; + } + + # Auto-extended arrays and elements which aren't explicitly + # filled in with a shared reference will puke under 5.8.0 + # ithreads. So we have to fill them in by hand. :( + my $empty_result = &share( {} ); + for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { + $test_results->[$idx] = $empty_result + unless defined $test_results->[$idx]; + } + + my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; + + my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; + + if( $num_extra != 0 ) { + my $s = $self->{Expected_Tests} == 1 ? '' : 's'; + $self->diag(<<"FAIL"); +Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. +FAIL + } + + if($num_failed) { + my $num_tests = $self->{Curr_Test}; + my $s = $num_failed == 1 ? '' : 's'; + + my $qualifier = $num_extra == 0 ? '' : ' run'; + + $self->diag(<<"FAIL"); +Looks like you failed $num_failed test$s of $num_tests$qualifier. +FAIL + } + + if($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. +FAIL + + _my_exit($real_exit_code) && return; + } + + my $exit_code; + if($num_failed) { + $exit_code = $num_failed <= 254 ? $num_failed : 254; + } + elsif( $num_extra != 0 ) { + $exit_code = 255; + } + else { + $exit_code = 0; + } + + _my_exit($exit_code) && return; + } + elsif( $self->{Skip_All} ) { + _my_exit(0) && return; + } + elsif($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code before it could output anything. +FAIL + _my_exit($real_exit_code) && return; + } + else { + $self->diag("No tests run!\n"); + _my_exit(255) && return; + } + + $self->_whoa( 1, "We fell off the end of _ending()" ); +} + +END { + $Test->_ending if defined $Test and !$Test->no_ending; +} + +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +=head1 THREADS + +In perl 5.8.1 and later, Test::Builder is thread-safe. The test +number is shared amongst all threads. This means if one thread sets +the test number using C<current_test()> they will all be effected. + +While versions earlier than 5.8.1 had threads they contain too many +bugs to support. + +Test::Builder is only thread-aware if threads.pm is loaded I<before> +Test::Builder. + +=head1 MEMORY + +An informative hash, accessable via C<<details()>>, is stored for each +test you perform. So memory usage will scale linearly with each test +run. Although this is not a problem for most test suites, it can +become an issue if you do large (hundred thousands to million) +combinatorics tests in the same run. + +In such cases, you are advised to either split the test file into smaller +ones, or use a reverse approach, doing "normal" (code) compares and +triggering fail() should anything go unexpected. + +Future versions of Test::Builder will have a way to turn history off. + + +=head1 EXAMPLES + +CPAN can provide the best examples. Test::Simple, Test::More, +Test::Exception and Test::Differences all use Test::Builder. + +=head1 SEE ALSO + +Test::Simple, Test::More, Test::Harness + +=head1 AUTHORS + +Original code by chromatic, maintained by Michael G Schwern +E<lt>schwern@pobox.comE<gt> + +=head1 COPYRIGHT + +Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and + Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=cut + +1; + diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm new file mode 100644 index 0000000000..a2d8e5bb60 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -0,0 +1,181 @@ +package Test::Builder::Module; + +use strict; + +use Test::Builder; + +require Exporter; +our @ISA = qw(Exporter); + +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +# 5.004's Exporter doesn't have export_to_level. +my $_export_to_level = sub { + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export( $callpkg, @_ ); +}; + +=head1 NAME + +Test::Builder::Module - Base class for test modules + +=head1 SYNOPSIS + + # Emulates Test::Simple + package Your::Module; + + my $CLASS = __PACKAGE__; + + use base 'Test::Builder::Module'; + @EXPORT = qw(ok); + + sub ok ($;$) { + my $tb = $CLASS->builder; + return $tb->ok(@_); + } + + 1; + + +=head1 DESCRIPTION + +This is a superclass for Test::Builder-based modules. It provides a +handful of common functionality and a method of getting at the underlying +Test::Builder object. + + +=head2 Importing + +Test::Builder::Module is a subclass of Exporter which means your +module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... +all act normally. + +A few methods are provided to do the C<use Your::Module tests => 23> part +for you. + +=head3 import + +Test::Builder::Module provides an import() method which acts in the +same basic way as Test::More's, setting the plan and controling +exporting of functions and variables. This allows your module to set +the plan independent of Test::More. + +All arguments passed to import() are passed onto +C<< Your::Module->builder->plan() >> with the exception of +C<import =>[qw(things to import)]>. + + use Your::Module import => [qw(this that)], tests => 23; + +says to import the functions this() and that() as well as set the plan +to be 23 tests. + +import() also sets the exported_to() attribute of your builder to be +the caller of the import() function. + +Additional behaviors can be added to your import() method by overriding +import_extra(). + +=cut + +sub import { + my($class) = shift; + + # Don't run all this when loading ourself. + return 1 if $class eq 'Test::Builder::Module'; + + my $test = $class->builder; + + my $caller = caller; + + $test->exported_to($caller); + + $class->import_extra( \@_ ); + my(@imports) = $class->_strip_imports( \@_ ); + + $test->plan(@_); + + $class->$_export_to_level( 1, $class, @imports ); +} + +sub _strip_imports { + my $class = shift; + my $list = shift; + + my @imports = (); + my @other = (); + my $idx = 0; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'import' ) { + push @imports, @{ $list->[ $idx + 1 ] }; + $idx++; + } + else { + push @other, $item; + } + + $idx++; + } + + @$list = @other; + + return @imports; +} + +=head3 import_extra + + Your::Module->import_extra(\@import_args); + +import_extra() is called by import(). It provides an opportunity for you +to add behaviors to your module based on its import list. + +Any extra arguments which shouldn't be passed on to plan() should be +stripped off by this method. + +See Test::More for an example of its use. + +B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it +feels like a bit of an ugly hack in its current form. + +=cut + +sub import_extra { } + +=head2 Builder + +Test::Builder::Module provides some methods of getting at the underlying +Test::Builder object. + +=head3 builder + + my $builder = Your::Class->builder; + +This method returns the Test::Builder object associated with Your::Class. +It is not a constructor so you can call it as often as you like. + +This is the preferred way to get the Test::Builder object. You should +I<not> get it via C<< Test::Builder->new >> as was previously +recommended. + +The object returned by builder() may change at runtime so you should +call builder() inside each function rather than store it in a global. + + sub ok { + my $builder = Your::Class->builder; + + return $builder->ok(@_); + } + + +=cut + +sub builder { + return Test::Builder->new; +} + +1; diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm new file mode 100644 index 0000000000..c019635584 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -0,0 +1,620 @@ +package Test::Builder::Tester; + +use strict; +our $VERSION = "1.18"; + +use Test::Builder; +use Symbol; +use Carp; + +=head1 NAME + +Test::Builder::Tester - test testsuites that have been built with +Test::Builder + +=head1 SYNOPSIS + + use Test::Builder::Tester tests => 1; + use Test::More; + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=head1 DESCRIPTION + +A module that helps you test testing modules that are built with +B<Test::Builder>. + +The testing system is designed to be used by performing a three step +process for each test you wish to test. This process starts with using +C<test_out> and C<test_err> in advance to declare what the testsuite you +are testing will output with B<Test::Builder> to stdout and stderr. + +You then can run the test(s) from your test suite that call +B<Test::Builder>. At this point the output of B<Test::Builder> is +safely captured by B<Test::Builder::Tester> rather than being +interpreted as real test output. + +The final stage is to call C<test_test> that will simply compare what you +predeclared to what B<Test::Builder> actually outputted, and report the +results back with a "ok" or "not ok" (with debugging) to the normal +output. + +=cut + +#### +# set up testing +#### + +my $t = Test::Builder->new; + +### +# make us an exporter +### + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); + +# _export_to_level and import stolen directly from Test::More. I am +# the king of cargo cult programming ;-) + +# 5.004's Exporter doesn't have export_to_level. +sub _export_to_level { + my $pkg = shift; + my $level = shift; + (undef) = shift; # XXX redundant arg + my $callpkg = caller($level); + $pkg->export( $callpkg, @_ ); +} + +sub import { + my $class = shift; + my(@plan) = @_; + + my $caller = caller; + + $t->exported_to($caller); + $t->plan(@plan); + + my @imports = (); + foreach my $idx ( 0 .. $#plan ) { + if( $plan[$idx] eq 'import' ) { + @imports = @{ $plan[ $idx + 1 ] }; + last; + } + } + + __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports ); +} + +### +# set up file handles +### + +# create some private file handles +my $output_handle = gensym; +my $error_handle = gensym; + +# and tie them to this package +my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; +my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; + +#### +# exported functions +#### + +# for remembering that we're testing and where we're testing at +my $testing = 0; +my $testing_num; + +# remembering where the file handles were originally connected +my $original_output_handle; +my $original_failure_handle; +my $original_todo_handle; + +my $original_test_number; +my $original_harness_state; + +my $original_harness_env; + +# function that starts testing and redirects the filehandles for now +sub _start_testing { + # even if we're running under Test::Harness pretend we're not + # for now. This needed so Test::Builder doesn't add extra spaces + $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; + $ENV{HARNESS_ACTIVE} = 0; + + # remember what the handles were set to + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); + + # switch out to our own handles + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($error_handle); + + # clear the expected list + $out->reset(); + $err->reset(); + + # remeber that we're testing + $testing = 1; + $testing_num = $t->current_test; + $t->current_test(0); + + # look, we shouldn't do the ending stuff + $t->no_ending(1); +} + +=head2 Functions + +These are the six methods that are exported as default. + +=over 4 + +=item test_out + +=item test_err + +Procedures for predeclaring the output that your test suite is +expected to produce until C<test_test> is called. These procedures +automatically assume that each line terminates with "\n". So + + test_out("ok 1","ok 2"); + +is the same as + + test_out("ok 1\nok 2"); + +which is even the same as + + test_out("ok 1"); + test_out("ok 2"); + +Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have +been called once all further output from B<Test::Builder> will be +captured by B<Test::Builder::Tester>. This means that your will not +be able perform further tests to the normal output in the normal way +until you call C<test_test> (well, unless you manually meddle with the +output filehandles) + +=cut + +sub test_out { + # do we need to do any setup? + _start_testing() unless $testing; + + $out->expect(@_); +} + +sub test_err { + # do we need to do any setup? + _start_testing() unless $testing; + + $err->expect(@_); +} + +=item test_fail + +Because the standard failure message that B<Test::Builder> produces +whenever a test fails will be a common occurrence in your test error +output, and because has changed between Test::Builder versions, rather +than forcing you to call C<test_err> with the string all the time like +so + + test_err("# Failed test ($0 at line ".line_num(+1).")"); + +C<test_fail> exists as a convenience function that can be called +instead. It takes one argument, the offset from the current line that +the line that causes the fail is on. + + test_fail(+1); + +This means that the example in the synopsis could be rewritten +more simply as: + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=cut + +sub test_fail { + # do we need to do any setup? + _start_testing() unless $testing; + + # work out what line we should be on + my( $package, $filename, $line ) = caller; + $line = $line + ( shift() || 0 ); # prevent warnings + + # expect that on stderr + $err->expect("# Failed test ($0 at line $line)"); +} + +=item test_diag + +As most of the remaining expected output to the error stream will be +created by Test::Builder's C<diag> function, B<Test::Builder::Tester> +provides a convience function C<test_diag> that you can use instead of +C<test_err>. + +The C<test_diag> function prepends comment hashes and spacing to the +start and newlines to the end of the expected output passed to it and +adds it to the list of expected error output. So, instead of writing + + test_err("# Couldn't open file"); + +you can write + + test_diag("Couldn't open file"); + +Remember that B<Test::Builder>'s diag function will not add newlines to +the end of output and test_diag will. So to check + + Test::Builder->new->diag("foo\n","bar\n"); + +You would do + + test_diag("foo","bar") + +without the newlines. + +=cut + +sub test_diag { + # do we need to do any setup? + _start_testing() unless $testing; + + # expect the same thing, but prepended with "# " + local $_; + $err->expect( map { "# $_" } @_ ); +} + +=item test_test + +Actually performs the output check testing the tests, comparing the +data (with C<eq>) that we have captured from B<Test::Builder> against +that that was declared with C<test_out> and C<test_err>. + +This takes name/value pairs that effect how the test is run. + +=over + +=item title (synonym 'name', 'label') + +The name of the test that will be displayed after the C<ok> or C<not +ok>. + +=item skip_out + +Setting this to a true value will cause the test to ignore if the +output sent by the test to the output stream does not match that +declared with C<test_out>. + +=item skip_err + +Setting this to a true value will cause the test to ignore if the +output sent by the test to the error stream does not match that +declared with C<test_err>. + +=back + +As a convience, if only one argument is passed then this argument +is assumed to be the name of the test (as in the above examples.) + +Once C<test_test> has been run test output will be redirected back to +the original filehandles that B<Test::Builder> was connected to +(probably STDOUT and STDERR,) meaning any further tests you run +will function normally and cause success/errors for B<Test::Harness>. + +=cut + +sub test_test { + # decode the arguements as described in the pod + my $mess; + my %args; + if( @_ == 1 ) { + $mess = shift + } + else { + %args = @_; + $mess = $args{name} if exists( $args{name} ); + $mess = $args{title} if exists( $args{title} ); + $mess = $args{label} if exists( $args{label} ); + } + + # er, are we testing? + croak "Not testing. You must declare output with a test function first." + unless $testing; + + # okay, reconnect the test suite back to the saved handles + $t->output($original_output_handle); + $t->failure_output($original_failure_handle); + $t->todo_output($original_todo_handle); + + # restore the test no, etc, back to the original point + $t->current_test($testing_num); + $testing = 0; + + # re-enable the original setting of the harness + $ENV{HARNESS_ACTIVE} = $original_harness_env; + + # check the output we've stashed + unless( $t->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) + ) + { + # print out the diagnostic information about why this + # test failed + + local $_; + + $t->diag( map { "$_\n" } $out->complaint ) + unless $args{skip_out} || $out->check; + + $t->diag( map { "$_\n" } $err->complaint ) + unless $args{skip_err} || $err->check; + } +} + +=item line_num + +A utility function that returns the line number that the function was +called on. You can pass it an offset which will be added to the +result. This is very useful for working out the correct text of +diagnostic functions that contain line numbers. + +Essentially this is the same as the C<__LINE__> macro, but the +C<line_num(+3)> idiom is arguably nicer. + +=cut + +sub line_num { + my( $package, $filename, $line ) = caller; + return $line + ( shift() || 0 ); # prevent warnings +} + +=back + +In addition to the six exported functions there there exists one +function that can only be accessed with a fully qualified function +call. + +=over 4 + +=item color + +When C<test_test> is called and the output that your tests generate +does not match that which you declared, C<test_test> will print out +debug information showing the two conflicting versions. As this +output itself is debug information it can be confusing which part of +the output is from C<test_test> and which was the original output from +your original tests. Also, it may be hard to spot things like +extraneous whitespace at the end of lines that may cause your test to +fail even though the output looks similar. + +To assist you, if you have the B<Term::ANSIColor> module installed +(which you should do by default from perl 5.005 onwards), C<test_test> +can colour the background of the debug information to disambiguate the +different types of output. The debug output will have it's background +coloured green and red. The green part represents the text which is +the same between the executed and actual output, the red shows which +part differs. + +The C<color> function determines if colouring should occur or not. +Passing it a true or false value will enable or disable colouring +respectively, and the function called with no argument will return the +current setting. + +To enable colouring from the command line, you can use the +B<Text::Builder::Tester::Color> module like so: + + perl -Mlib=Text::Builder::Tester::Color test.t + +Or by including the B<Test::Builder::Tester::Color> module directly in +the PERL5LIB. + +=cut + +my $color; + +sub color { + $color = shift if @_; + $color; +} + +=back + +=head1 BUGS + +Calls C<<Test::Builder->no_ending>> turning off the ending tests. +This is needed as otherwise it will trip out because we've run more +tests than we strictly should have and it'll register any failures we +had that we were testing for as real failures. + +The color function doesn't work unless B<Term::ANSIColor> is installed +and is compatible with your terminal. + +Bugs (and requests for new features) can be reported to the author +though the CPAN RT system: +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester> + +=head1 AUTHOR + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. + +Some code taken from B<Test::More> and B<Test::Catch>, written by by +Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts +Copyright Micheal G Schwern 2001. Used and distributed with +permission. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 NOTES + +This code has been tested explicitly on the following versions +of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004. + +Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting +me use his testing system to try this module out on. + +=head1 SEE ALSO + +L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>. + +=cut + +1; + +#################################################################### +# Helper class that is used to remember expected and received data + +package Test::Builder::Tester::Tie; + +## +# add line(s) to be expected + +sub expect { + my $self = shift; + + my @checks = @_; + foreach my $check (@checks) { + $check = $self->_translate_Failed_check($check); + push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; + } +} + +sub _translate_Failed_check { + my( $self, $check ) = @_; + + if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { + $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; + } + + return $check; +} + +## +# return true iff the expected data matches the got data + +sub check { + my $self = shift; + + # turn off warnings as these might be undef + local $^W = 0; + + my @checks = @{ $self->{wanted} }; + my $got = $self->{got}; + foreach my $check (@checks) { + $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); + return 0 unless $got =~ s/^$check//; + } + + return length $got == 0; +} + +## +# a complaint message about the inputs not matching (to be +# used for debugging messages) + +sub complaint { + my $self = shift; + my $type = $self->type; + my $got = $self->got; + my $wanted = join "\n", @{ $self->wanted }; + + # are we running in colour mode? + if(Test::Builder::Tester::color) { + # get color + eval { require Term::ANSIColor }; + unless($@) { + # colours + + my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); + my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red"); + my $reset = Term::ANSIColor::color("reset"); + + # work out where the two strings start to differ + my $char = 0; + $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); + + # get the start string and the two end strings + my $start = $green . substr( $wanted, 0, $char ); + my $gotend = $red . substr( $got, $char ) . $reset; + my $wantedend = $red . substr( $wanted, $char ) . $reset; + + # make the start turn green on and off + $start =~ s/\n/$reset\n$green/g; + + # make the ends turn red on and off + $gotend =~ s/\n/$reset\n$red/g; + $wantedend =~ s/\n/$reset\n$red/g; + + # rebuild the strings + $got = $start . $gotend; + $wanted = $start . $wantedend; + } + } + + return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; +} + +## +# forget all expected and got data + +sub reset { + my $self = shift; + %$self = ( + type => $self->{type}, + got => '', + wanted => [], + ); +} + +sub got { + my $self = shift; + return $self->{got}; +} + +sub wanted { + my $self = shift; + return $self->{wanted}; +} + +sub type { + my $self = shift; + return $self->{type}; +} + +### +# tie interface +### + +sub PRINT { + my $self = shift; + $self->{got} .= join '', @_; +} + +sub TIEHANDLE { + my( $class, $type ) = @_; + + my $self = bless { type => $type }, $class; + + $self->reset; + + return $self; +} + +sub READ { } +sub READLINE { } +sub GETC { } +sub FILENO { } + +1; diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm new file mode 100644 index 0000000000..264fddbfd8 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -0,0 +1,51 @@ +package Test::Builder::Tester::Color; + +use strict; +our $VERSION = "1.18"; + +require Test::Builder::Tester; + + +=head1 NAME + +Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester + +=head1 SYNOPSIS + + When running a test script + + perl -MTest::Builder::Tester::Color test.t + +=head1 DESCRIPTION + +Importing this module causes the subroutine color in Test::Builder::Tester +to be called with a true value causing colour highlighting to be turned +on in debug output. + +The sole purpose of this module is to enable colour highlighting +from the command line. + +=cut + +sub import { + Test::Builder::Tester::color(1); +} + +=head1 AUTHOR + +Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 BUGS + +This module will have no effect unless Term::ANSIColor is installed. + +=head1 SEE ALSO + +L<Test::Builder::Tester>, L<Term::ANSIColor> + +=cut + +1; diff --git a/cpan/Test-Simple/lib/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm new file mode 100644 index 0000000000..aaf6d8721b --- /dev/null +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -0,0 +1,1737 @@ +package Test::More; + +use 5.006; +use strict; +use warnings; + +#---- perlcritic exemptions. ----# + +# We use a lot of subroutine prototypes +## no critic (Subroutines::ProhibitSubroutinePrototypes) + +# Can't use Carp because it might cause use_ok() to accidentally succeed +# even though the module being used forgot to use Carp. Yes, this +# actually happened. +sub _carp { + my( $file, $line ) = ( caller(1) )[ 1, 2 ]; + return warn @_, " at $file line $line\n"; +} + +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +use Test::Builder::Module; +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok use_ok require_ok + is isnt like unlike is_deeply + cmp_ok + skip todo todo_skip + pass fail + eq_array eq_hash eq_set + $TODO + plan + done_testing + can_ok isa_ok new_ok + diag note explain + BAIL_OUT +); + +=head1 NAME + +Test::More - yet another framework for writing test scripts + +=head1 SYNOPSIS + + use Test::More tests => 23; + # or + use Test::More skip_all => $reason; + # or + use Test::More; # see done_testing() + + BEGIN { use_ok( 'Some::Module' ); } + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($got eq $expected, $test_name); + + is ($got, $expected, $test_name); + isnt($got, $expected, $test_name); + + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); + + like ($got, qr/expected/, $test_name); + unlike($got, qr/expected/, $test_name); + + cmp_ok($got, '==', $expected, $test_name); + + is_deeply($got_complex_structure, $expected_complex_structure, $test_name); + + SKIP: { + skip $why, $how_many unless $have_some_feature; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + TODO: { + local $TODO = $why; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + can_ok($module, @methods); + isa_ok($object, $class); + + pass($test_name); + fail($test_name); + + BAIL_OUT($why); + + # UNIMPLEMENTED!!! + my @status = Test::More::status; + + +=head1 DESCRIPTION + +B<STOP!> If you're just getting started writing tests, have a look at +L<Test::Simple> first. This is a drop in replacement for Test::Simple +which you can switch to once you get the hang of basic testing. + +The purpose of this module is to provide a wide range of testing +utilities. Various ways to say "ok" with better diagnostics, +facilities to skip tests, test future features and compare complicated +data structures. While you can do almost anything with a simple +C<ok()> function, it doesn't provide good diagnostic output. + + +=head2 I love it when a plan comes together + +Before anything else, you need a testing plan. This basically declares +how many tests your script is going to run to protect against premature +failure. + +The preferred way to do this is to declare a plan when you C<use Test::More>. + + use Test::More tests => 23; + +There are cases when you will not know beforehand how many tests your +script is going to run. In this case, you can declare your tests at +the end. + + use Test::More; + + ... run your tests ... + + done_testing( $number_of_tests_run ); + +Sometimes you really don't know how many tests were run, or it's too +difficult to calculate. In which case you can leave off +$number_of_tests_run. + +In some cases, you'll want to completely skip an entire testing script. + + use Test::More skip_all => $skip_reason; + +Your script will declare a skip with the reason why you skipped and +exit immediately with a zero (success). See L<Test::Harness> for +details. + +If you want to control what functions Test::More will export, you +have to use the 'import' option. For example, to import everything +but 'fail', you'd do: + + use Test::More tests => 23, import => ['!fail']; + +Alternatively, you can use the plan() function. Useful for when you +have to calculate the number of tests. + + use Test::More; + plan tests => keys %Stuff * 3; + +or for deciding between running the tests at all: + + use Test::More; + if( $^O eq 'MacOS' ) { + plan skip_all => 'Test irrelevant on MacOS'; + } + else { + plan tests => 42; + } + +=cut + +sub plan { + my $tb = Test::More->builder; + + return $tb->plan(@_); +} + +# This implements "use Test::More 'no_diag'" but the behavior is +# deprecated. +sub import_extra { + my $class = shift; + my $list = shift; + + my @other = (); + my $idx = 0; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'no_diag' ) { + $class->builder->no_diag(1); + } + else { + push @other, $item; + } + + $idx++; + } + + @$list = @other; + + return; +} + +=over 4 + +=item B<done_testing> + + done_testing(); + done_testing($number_of_tests); + +If you don't know how many tests you're going to run, you can issue +the plan when you're done running tests. + +$number_of_tests is the same as plan(), it's the number of tests you +expected to run. You can omit this, in which case the number of tests +you ran doesn't matter, just the fact that your tests ran to +conclusion. + +This is safer than and replaces the "no_plan" plan. + +=back + +=cut + +sub done_testing { + my $tb = Test::More->builder; + $tb->done_testing(@_); +} + +=head2 Test names + +By convention, each test is assigned a number in order. This is +largely done automatically for you. However, it's often very useful to +assign a name to each test. Which would you rather see: + + ok 4 + not ok 5 + ok 6 + +or + + ok 4 - basic multi-variable + not ok 5 - simple exponential + ok 6 - force == mass * acceleration + +The later gives you some idea of what failed. It also makes it easier +to find the test in your script, simply search for "simple +exponential". + +All test functions take a name argument. It's optional, but highly +suggested that you use it. + + +=head2 I'm ok, you're not ok. + +The basic purpose of this module is to print out either "ok #" or "not +ok #" depending on if a given test succeeded or failed. Everything +else is just gravy. + +All of the following print "ok" or "not ok" depending on if the test +succeeded or failed. They all also return true or false, +respectively. + +=over 4 + +=item B<ok> + + ok($got eq $expected, $test_name); + +This simply evaluates any expression (C<$got eq $expected> is just a +simple example) and uses that to determine if the test succeeded or +failed. A true expression passes, a false one fails. Very simple. + +For example: + + ok( $exp{9} == 81, 'simple exponential' ); + ok( Film->can('db_Main'), 'set_db()' ); + ok( $p->tests == 4, 'saw tests' ); + ok( !grep !defined $_, @items, 'items populated' ); + +(Mnemonic: "This is ok.") + +$test_name is a very short description of the test that will be printed +out. It makes it very easy to find a test in your script when it fails +and gives others an idea of your intentions. $test_name is optional, +but we B<very> strongly encourage its use. + +Should an ok() fail, it will produce some diagnostics: + + not ok 18 - sufficient mucus + # Failed test 'sufficient mucus' + # in foo.t at line 42. + +This is the same as Test::Simple's ok() routine. + +=cut + +sub ok ($;$) { + my( $test, $name ) = @_; + my $tb = Test::More->builder; + + return $tb->ok( $test, $name ); +} + +=item B<is> + +=item B<isnt> + + is ( $got, $expected, $test_name ); + isnt( $got, $expected, $test_name ); + +Similar to ok(), is() and isnt() compare their two arguments +with C<eq> and C<ne> respectively and use the result of that to +determine if the test succeeded or failed. So these: + + # Is the ultimate answer 42? + is( ultimate_answer(), 42, "Meaning of Life" ); + + # $foo isn't empty + isnt( $foo, '', "Got some foo" ); + +are similar to these: + + ok( ultimate_answer() eq 42, "Meaning of Life" ); + ok( $foo ne '', "Got some foo" ); + +(Mnemonic: "This is that." "This isn't that.") + +So why use these? They produce better diagnostics on failure. ok() +cannot know what you are testing for (beyond the name), but is() and +isnt() know what the test was and why it failed. For example this +test: + + my $foo = 'waffle'; my $bar = 'yarblokos'; + is( $foo, $bar, 'Is foo the same as bar?' ); + +Will produce something like this: + + not ok 17 - Is foo the same as bar? + # Failed test 'Is foo the same as bar?' + # in foo.t at line 139. + # got: 'waffle' + # expected: 'yarblokos' + +So you can figure out what went wrong without rerunning the test. + +You are encouraged to use is() and isnt() over ok() where possible, +however do not be tempted to use them to find out if something is +true or false! + + # XXX BAD! + is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); + +This does not check if C<exists $brooklyn{tree}> is true, it checks if +it returns 1. Very different. Similar caveats exist for false and 0. +In these cases, use ok(). + + ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); + +A simple call to isnt() usually does not provide a strong test but there +are cases when you cannot say much more about a value than that it is +different from some other value: + + new_ok $obj, "Foo"; + + my $clone = $obj->clone; + isa_ok $obj, "Foo", "Foo->clone"; + + isnt $obj, $clone, "clone() produces a different object"; + +For those grammatical pedants out there, there's an C<isn't()> +function which is an alias of isnt(). + +=cut + +sub is ($$;$) { + my $tb = Test::More->builder; + + return $tb->is_eq(@_); +} + +sub isnt ($$;$) { + my $tb = Test::More->builder; + + return $tb->isnt_eq(@_); +} + +*isn't = \&isnt; + +=item B<like> + + like( $got, qr/expected/, $test_name ); + +Similar to ok(), like() matches $got against the regex C<qr/expected/>. + +So this: + + like($got, qr/expected/, 'this is like that'); + +is similar to: + + ok( $got =~ /expected/, 'this is like that'); + +(Mnemonic "This is like that".) + +The second argument is a regular expression. It may be given as a +regex reference (i.e. C<qr//>) or (for better compatibility with older +perls) as a string that looks like a regex (alternative delimiters are +currently not supported): + + like( $got, '/expected/', 'this is like that' ); + +Regex options may be placed on the end (C<'/expected/i'>). + +Its advantages over ok() are similar to that of is() and isnt(). Better +diagnostics on failure. + +=cut + +sub like ($$;$) { + my $tb = Test::More->builder; + + return $tb->like(@_); +} + +=item B<unlike> + + unlike( $got, qr/expected/, $test_name ); + +Works exactly as like(), only it checks if $got B<does not> match the +given pattern. + +=cut + +sub unlike ($$;$) { + my $tb = Test::More->builder; + + return $tb->unlike(@_); +} + +=item B<cmp_ok> + + cmp_ok( $got, $op, $expected, $test_name ); + +Halfway between ok() and is() lies cmp_ok(). This allows you to +compare two arguments using any binary perl operator. + + # ok( $got eq $expected ); + cmp_ok( $got, 'eq', $expected, 'this eq that' ); + + # ok( $got == $expected ); + cmp_ok( $got, '==', $expected, 'this == that' ); + + # ok( $got && $expected ); + cmp_ok( $got, '&&', $expected, 'this && that' ); + ...etc... + +Its advantage over ok() is when the test fails you'll know what $got +and $expected were: + + not ok 1 + # Failed test in foo.t at line 12. + # '23' + # && + # undef + +It's also useful in those cases where you are comparing numbers and +is()'s use of C<eq> will interfere: + + cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); + +It's especially useful when comparing greater-than or smaller-than +relation between values: + + cmp_ok( $some_value, '<=', $upper_limit ); + + +=cut + +sub cmp_ok($$$;$) { + my $tb = Test::More->builder; + + return $tb->cmp_ok(@_); +} + +=item B<can_ok> + + can_ok($module, @methods); + can_ok($object, @methods); + +Checks to make sure the $module or $object can do these @methods +(works with functions, too). + + can_ok('Foo', qw(this that whatever)); + +is almost exactly like saying: + + ok( Foo->can('this') && + Foo->can('that') && + Foo->can('whatever') + ); + +only without all the typing and with a better interface. Handy for +quickly testing an interface. + +No matter how many @methods you check, a single can_ok() call counts +as one test. If you desire otherwise, use: + + foreach my $meth (@methods) { + can_ok('Foo', $meth); + } + +=cut + +sub can_ok ($@) { + my( $proto, @methods ) = @_; + my $class = ref $proto || $proto; + my $tb = Test::More->builder; + + unless($class) { + my $ok = $tb->ok( 0, "->can(...)" ); + $tb->diag(' can_ok() called with empty class or reference'); + return $ok; + } + + unless(@methods) { + my $ok = $tb->ok( 0, "$class->can(...)" ); + $tb->diag(' can_ok() called with no methods'); + return $ok; + } + + my @nok = (); + foreach my $method (@methods) { + $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; + } + + my $name = (@methods == 1) ? "$class->can('$methods[0]')" : + "$class->can(...)" ; + + my $ok = $tb->ok( !@nok, $name ); + + $tb->diag( map " $class->can('$_') failed\n", @nok ); + + return $ok; +} + +=item B<isa_ok> + + isa_ok($object, $class, $object_name); + isa_ok($subclass, $class, $object_name); + isa_ok($ref, $type, $ref_name); + +Checks to see if the given C<< $object->isa($class) >>. Also checks to make +sure the object was defined in the first place. Handy for this sort +of thing: + + my $obj = Some::Module->new; + isa_ok( $obj, 'Some::Module' ); + +where you'd otherwise have to write + + my $obj = Some::Module->new; + ok( defined $obj && $obj->isa('Some::Module') ); + +to safeguard against your test script blowing up. + +You can also test a class, to make sure that it has the right ancestor: + + isa_ok( 'Vole', 'Rodent' ); + +It works on references, too: + + isa_ok( $array_ref, 'ARRAY' ); + +The diagnostics of this test normally just refer to 'the object'. If +you'd like them to be more specific, you can supply an $object_name +(for example 'Test customer'). + +=cut + +sub isa_ok ($$;$) { + my( $object, $class, $obj_name ) = @_; + my $tb = Test::More->builder; + + my $diag; + + if( !defined $object ) { + $obj_name = 'The thing' unless defined $obj_name; + $diag = "$obj_name isn't defined"; + } + else { + my $whatami = ref $object ? 'object' : 'class'; + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); + if($error) { + if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { + # Its an unblessed reference + $obj_name = 'The reference' unless defined $obj_name; + if( !UNIVERSAL::isa( $object, $class ) ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } + elsif( $error =~ /Can't call method "isa" without a package/ ) { + # It's something that can't even be a class + $diag = "$obj_name isn't a class or reference"; + } + else { + die <<WHOA; +WHOA! I tried to call ->isa on your $whatami and got some weird error. +Here's the error. +$error +WHOA + } + } + else { + $obj_name = "The $whatami" unless defined $obj_name; + if( !$rslt ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } + } + + my $name = "$obj_name isa $class"; + my $ok; + if($diag) { + $ok = $tb->ok( 0, $name ); + $tb->diag(" $diag\n"); + } + else { + $ok = $tb->ok( 1, $name ); + } + + return $ok; +} + +=item B<new_ok> + + my $obj = new_ok( $class ); + my $obj = new_ok( $class => \@args ); + my $obj = new_ok( $class => \@args, $object_name ); + +A convenience function which combines creating an object and calling +isa_ok() on that object. + +It is basically equivalent to: + + my $obj = $class->new(@args); + isa_ok $obj, $class, $object_name; + +If @args is not given, an empty list will be used. + +This function only works on new() and it assumes new() will return +just a single object which isa C<$class>. + +=cut + +sub new_ok { + my $tb = Test::More->builder; + $tb->croak("new_ok() must be given at least a class") unless @_; + + my( $class, $args, $object_name ) = @_; + + $args ||= []; + $object_name = "The object" unless defined $object_name; + + my $obj; + my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); + if($success) { + local $Test::Builder::Level = $Test::Builder::Level + 1; + isa_ok $obj, $class, $object_name; + } + else { + $tb->ok( 0, "new() died" ); + $tb->diag(" Error was: $error"); + } + + return $obj; +} + +=item B<pass> + +=item B<fail> + + pass($test_name); + fail($test_name); + +Sometimes you just want to say that the tests have passed. Usually +the case is you've got some complicated condition that is difficult to +wedge into an ok(). In this case, you can simply use pass() (to +declare the test ok) or fail (for not ok). They are synonyms for +ok(1) and ok(0). + +Use these very, very, very sparingly. + +=cut + +sub pass (;$) { + my $tb = Test::More->builder; + + return $tb->ok( 1, @_ ); +} + +sub fail (;$) { + my $tb = Test::More->builder; + + return $tb->ok( 0, @_ ); +} + +=back + + +=head2 Module tests + +You usually want to test if the module you're testing loads ok, rather +than just vomiting if its load fails. For such purposes we have +C<use_ok> and C<require_ok>. + +=over 4 + +=item B<use_ok> + + BEGIN { use_ok($module); } + BEGIN { use_ok($module, @imports); } + +These simply use the given $module and test to make sure the load +happened ok. It's recommended that you run use_ok() inside a BEGIN +block so its functions are exported at compile-time and prototypes are +properly honored. + +If @imports are given, they are passed through to the use. So this: + + BEGIN { use_ok('Some::Module', qw(foo bar)) } + +is like doing this: + + use Some::Module qw(foo bar); + +Version numbers can be checked like so: + + # Just like "use Some::Module 1.02" + BEGIN { use_ok('Some::Module', 1.02) } + +Don't try to do this: + + BEGIN { + use_ok('Some::Module'); + + ...some code that depends on the use... + ...happening at compile time... + } + +because the notion of "compile-time" is relative. Instead, you want: + + BEGIN { use_ok('Some::Module') } + BEGIN { ...some code that depends on the use... } + + +=cut + +sub use_ok ($;@) { + my( $module, @imports ) = @_; + @imports = () unless @imports; + my $tb = Test::More->builder; + + my( $pack, $filename, $line ) = caller; + + my $code; + if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { + # probably a version check. Perl needs to see the bare number + # for it to work with non-Exporter based modules. + $code = <<USE; +package $pack; +use $module $imports[0]; +1; +USE + } + else { + $code = <<USE; +package $pack; +use $module \@{\$args[0]}; +1; +USE + } + + my( $eval_result, $eval_error ) = _eval( $code, \@imports ); + my $ok = $tb->ok( $eval_result, "use $module;" ); + + unless($ok) { + chomp $eval_error; + $@ =~ s{^BEGIN failed--compilation aborted at .*$} + {BEGIN failed--compilation aborted at $filename line $line.}m; + $tb->diag(<<DIAGNOSTIC); + Tried to use '$module'. + Error: $eval_error +DIAGNOSTIC + + } + + return $ok; +} + +sub _eval { + my( $code, @args ) = @_; + + # Work around oddities surrounding resetting of $@ by immediately + # storing it. + my( $sigdie, $eval_result, $eval_error ); + { + local( $@, $!, $SIG{__DIE__} ); # isolate eval + $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval) + $eval_error = $@; + $sigdie = $SIG{__DIE__} || undef; + } + # make sure that $code got a chance to set $SIG{__DIE__} + $SIG{__DIE__} = $sigdie if defined $sigdie; + + return( $eval_result, $eval_error ); +} + +=item B<require_ok> + + require_ok($module); + require_ok($file); + +Like use_ok(), except it requires the $module or $file. + +=cut + +sub require_ok ($) { + my($module) = shift; + my $tb = Test::More->builder; + + my $pack = caller; + + # Try to deterine if we've been given a module name or file. + # Module names must be barewords, files not. + $module = qq['$module'] unless _is_module_name($module); + + my $code = <<REQUIRE; +package $pack; +require $module; +1; +REQUIRE + + my( $eval_result, $eval_error ) = _eval($code); + my $ok = $tb->ok( $eval_result, "require $module;" ); + + unless($ok) { + chomp $eval_error; + $tb->diag(<<DIAGNOSTIC); + Tried to require '$module'. + Error: $eval_error +DIAGNOSTIC + + } + + return $ok; +} + +sub _is_module_name { + my $module = shift; + + # Module names start with a letter. + # End with an alphanumeric. + # The rest is an alphanumeric or :: + $module =~ s/\b::\b//g; + + return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0; +} + +=back + + +=head2 Complex data structures + +Not everything is a simple eq check or regex. There are times you +need to see if two data structures are equivalent. For these +instances Test::More provides a handful of useful functions. + +B<NOTE> I'm not quite sure what will happen with filehandles. + +=over 4 + +=item B<is_deeply> + + is_deeply( $got, $expected, $test_name ); + +Similar to is(), except that if $got and $expected are references, it +does a deep comparison walking each data structure to see if they are +equivalent. If the two structures are different, it will display the +place where they start differing. + +is_deeply() compares the dereferenced values of references, the +references themselves (except for their type) are ignored. This means +aspects such as blessing and ties are not considered "different". + +is_deeply() currently has very limited handling of function reference +and globs. It merely checks if they have the same referent. This may +improve in the future. + +L<Test::Differences> and L<Test::Deep> provide more in-depth functionality +along these lines. + +=cut + +our( @Data_Stack, %Refs_Seen ); +my $DNE = bless [], 'Does::Not::Exist'; + +sub _dne { + return ref $_[0] eq ref $DNE; +} + +## no critic (Subroutines::RequireArgUnpacking) +sub is_deeply { + my $tb = Test::More->builder; + + unless( @_ == 2 or @_ == 3 ) { + my $msg = <<'WARNING'; +is_deeply() takes two or three args, you gave %d. +This usually means you passed an array or hash instead +of a reference to it +WARNING + chop $msg; # clip off newline so carp() will put in line/file + + _carp sprintf $msg, scalar @_; + + return $tb->ok(0); + } + + my( $got, $expected, $name ) = @_; + + $tb->_unoverload_str( \$expected, \$got ); + + my $ok; + if( !ref $got and !ref $expected ) { # neither is a reference + $ok = $tb->is_eq( $got, $expected, $name ); + } + elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't + $ok = $tb->ok( 0, $name ); + $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); + } + else { # both references + local @Data_Stack = (); + if( _deep_check( $got, $expected ) ) { + $ok = $tb->ok( 1, $name ); + } + else { + $ok = $tb->ok( 0, $name ); + $tb->diag( _format_stack(@Data_Stack) ); + } + } + + return $ok; +} + +sub _format_stack { + my(@Stack) = @_; + + my $var = '$FOO'; + my $did_arrow = 0; + foreach my $entry (@Stack) { + my $type = $entry->{type} || ''; + my $idx = $entry->{'idx'}; + if( $type eq 'HASH' ) { + $var .= "->" unless $did_arrow++; + $var .= "{$idx}"; + } + elsif( $type eq 'ARRAY' ) { + $var .= "->" unless $did_arrow++; + $var .= "[$idx]"; + } + elsif( $type eq 'REF' ) { + $var = "\${$var}"; + } + } + + my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; + my @vars = (); + ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; + ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; + + my $out = "Structures begin differing at:\n"; + foreach my $idx ( 0 .. $#vals ) { + my $val = $vals[$idx]; + $vals[$idx] + = !defined $val ? 'undef' + : _dne($val) ? "Does not exist" + : ref $val ? "$val" + : "'$val'"; + } + + $out .= "$vars[0] = $vals[0]\n"; + $out .= "$vars[1] = $vals[1]\n"; + + $out =~ s/^/ /msg; + return $out; +} + +sub _type { + my $thing = shift; + + return '' if !ref $thing; + + for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { + return $type if UNIVERSAL::isa( $thing, $type ); + } + + return ''; +} + +=back + + +=head2 Diagnostics + +If you pick the right test function, you'll usually get a good idea of +what went wrong when it failed. But sometimes it doesn't work out +that way. So here we have ways for you to write your own diagnostic +messages which are safer than just C<print STDERR>. + +=over 4 + +=item B<diag> + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Like C<print> @diagnostic_message is simply concatenated +together. + +Returns false, so as to preserve failure. + +Handy for this sort of thing: + + ok( grep(/foo/, @users), "There's a foo user" ) or + diag("Since there's no foo, check that /etc/bar is set up right"); + +which would produce: + + not ok 42 - There's a foo user + # Failed test 'There's a foo user' + # in foo.t at line 52. + # Since there's no foo, check that /etc/bar is set up right. + +You might remember C<ok() or diag()> with the mnemonic C<open() or +die()>. + +B<NOTE> The exact formatting of the diagnostic output is still +changing, but it is guaranteed that whatever you throw at it it won't +interfere with the test. + +=item B<note> + + note(@diagnostic_message); + +Like diag(), except the message will not be seen when the test is run +in a harness. It will only be visible in the verbose TAP stream. + +Handy for putting in notes which might be useful for debugging, but +don't indicate a problem. + + note("Tempfile is $tempfile"); + +=cut + +sub diag { + return Test::More->builder->diag(@_); +} + +sub note { + return Test::More->builder->note(@_); +} + +=item B<explain> + + my @dump = explain @diagnostic_message; + +Will dump the contents of any references in a human readable format. +Usually you want to pass this into C<note> or C<diag>. + +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + note explain \%args; + Some::Class->method(%args); + +=cut + +sub explain { + return Test::More->builder->explain(@_); +} + +=back + + +=head2 Conditional tests + +Sometimes running a test under certain conditions will cause the +test script to die. A certain function or method isn't implemented +(such as fork() on MacOS), some resource isn't available (like a +net connection) or a module isn't available. In these cases it's +necessary to skip tests, or declare that they are supposed to fail +but will work in the future (a todo test). + +For more details on the mechanics of skip and todo tests see +L<Test::Harness>. + +The way Test::More handles this is with a named block. Basically, a +block of tests which can be skipped over or made todo. It's best if I +just show you... + +=over 4 + +=item B<SKIP: BLOCK> + + SKIP: { + skip $why, $how_many if $condition; + + ...normal testing code goes here... + } + +This declares a block of tests that might be skipped, $how_many tests +there are, $why and under what $condition to skip them. An example is +the easiest way to illustrate: + + SKIP: { + eval { require HTML::Lint }; + + skip "HTML::Lint not installed", 2 if $@; + + my $lint = new HTML::Lint; + isa_ok( $lint, "HTML::Lint" ); + + $lint->parse( $html ); + is( $lint->errors, 0, "No errors found in HTML" ); + } + +If the user does not have HTML::Lint installed, the whole block of +code I<won't be run at all>. Test::More will output special ok's +which Test::Harness interprets as skipped, but passing, tests. + +It's important that $how_many accurately reflects the number of tests +in the SKIP block so the # of tests run will match up with your plan. +If your plan is C<no_plan> $how_many is optional and will default to 1. + +It's perfectly safe to nest SKIP blocks. Each SKIP block must have +the label C<SKIP>, or Test::More can't work its magic. + +You don't skip tests which are failing because there's a bug in your +program, or for which you don't yet have code written. For that you +use TODO. Read on. + +=cut + +## no critic (Subroutines::RequireFinalReturn) +sub skip { + my( $why, $how_many ) = @_; + my $tb = Test::More->builder; + + unless( defined $how_many ) { + # $how_many can only be avoided when no_plan is in use. + _carp "skip() needs to know \$how_many tests are in the block" + unless $tb->has_plan eq 'no_plan'; + $how_many = 1; + } + + if( defined $how_many and $how_many =~ /\D/ ) { + _carp + "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; + $how_many = 1; + } + + for( 1 .. $how_many ) { + $tb->skip($why); + } + + no warnings 'exiting'; + last SKIP; +} + +=item B<TODO: BLOCK> + + TODO: { + local $TODO = $why if $condition; + + ...normal testing code goes here... + } + +Declares a block of tests you expect to fail and $why. Perhaps it's +because you haven't fixed a bug or haven't finished a new feature: + + TODO: { + local $TODO = "URI::Geller not finished"; + + my $card = "Eight of clubs"; + is( URI::Geller->your_card, $card, 'Is THIS your card?' ); + + my $spoon; + URI::Geller->bend_spoon; + is( $spoon, 'bent', "Spoon bending, that's original" ); + } + +With a todo block, the tests inside are expected to fail. Test::More +will run the tests normally, but print out special flags indicating +they are "todo". Test::Harness will interpret failures as being ok. +Should anything succeed, it will report it as an unexpected success. +You then know the thing you had todo is done and can remove the +TODO flag. + +The nice part about todo tests, as opposed to simply commenting out a +block of tests, is it's like having a programmatic todo list. You know +how much work is left to be done, you're aware of what bugs there are, +and you'll know immediately when they're fixed. + +Once a todo test starts succeeding, simply move it outside the block. +When the block is empty, delete it. + +B<NOTE>: TODO tests require a Test::Harness upgrade else it will +treat it as a normal failure. See L<CAVEATS and NOTES>). + + +=item B<todo_skip> + + TODO: { + todo_skip $why, $how_many if $condition; + + ...normal testing code... + } + +With todo tests, it's best to have the tests actually run. That way +you'll know when they start passing. Sometimes this isn't possible. +Often a failing test will cause the whole program to die or hang, even +inside an C<eval BLOCK> with and using C<alarm>. In these extreme +cases you have no choice but to skip over the broken tests entirely. + +The syntax and behavior is similar to a C<SKIP: BLOCK> except the +tests will be marked as failing but todo. Test::Harness will +interpret them as passing. + +=cut + +sub todo_skip { + my( $why, $how_many ) = @_; + my $tb = Test::More->builder; + + unless( defined $how_many ) { + # $how_many can only be avoided when no_plan is in use. + _carp "todo_skip() needs to know \$how_many tests are in the block" + unless $tb->has_plan eq 'no_plan'; + $how_many = 1; + } + + for( 1 .. $how_many ) { + $tb->todo_skip($why); + } + + no warnings 'exiting'; + last TODO; +} + +=item When do I use SKIP vs. TODO? + +B<If it's something the user might not be able to do>, use SKIP. +This includes optional modules that aren't installed, running under +an OS that doesn't have some feature (like fork() or symlinks), or maybe +you need an Internet connection and one isn't available. + +B<If it's something the programmer hasn't done yet>, use TODO. This +is for any code you haven't written yet, or bugs you have yet to fix, +but want to put tests in your testing script (always a good idea). + + +=back + + +=head2 Test control + +=over 4 + +=item B<BAIL_OUT> + + BAIL_OUT($reason); + +Indicates to the harness that things are going so badly all testing +should terminate. This includes the running any additional test scripts. + +This is typically used when testing cannot continue such as a critical +module failing to compile or a necessary external utility not being +available such as a database connection failing. + +The test will exit with 255. + +For even better control look at L<Test::Most>. + +=cut + +sub BAIL_OUT { + my $reason = shift; + my $tb = Test::More->builder; + + $tb->BAIL_OUT($reason); +} + +=back + + +=head2 Discouraged comparison functions + +The use of the following functions is discouraged as they are not +actually testing functions and produce no diagnostics to help figure +out what went wrong. They were written before is_deeply() existed +because I couldn't figure out how to display a useful diff of two +arbitrary data structures. + +These functions are usually used inside an ok(). + + ok( eq_array(\@got, \@expected) ); + +C<is_deeply()> can do that better and with diagnostics. + + is_deeply( \@got, \@expected ); + +They may be deprecated in future versions. + +=over 4 + +=item B<eq_array> + + my $is_eq = eq_array(\@got, \@expected); + +Checks if two arrays are equivalent. This is a deep check, so +multi-level structures are handled correctly. + +=cut + +#'# +sub eq_array { + local @Data_Stack = (); + _deep_check(@_); +} + +sub _eq_array { + my( $a1, $a2 ) = @_; + + if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { + warn "eq_array passed a non-array ref"; + return 0; + } + + return 1 if $a1 eq $a2; + + my $ok = 1; + my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; + for( 0 .. $max ) { + my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; + my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; + + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); + pop @Data_Stack if $ok; + + last unless $ok; + } + + return $ok; +} + +sub _deep_check { + my( $e1, $e2 ) = @_; + my $tb = Test::More->builder; + + my $ok = 0; + + # Effectively turn %Refs_Seen into a stack. This avoids picking up + # the same referenced used twice (such as [\$a, \$a]) to be considered + # circular. + local %Refs_Seen = %Refs_Seen; + + { + # Quiet uninitialized value warnings when comparing undefs. + no warnings 'uninitialized'; + + $tb->_unoverload_str( \$e1, \$e2 ); + + # Either they're both references or both not. + my $same_ref = !( !ref $e1 xor !ref $e2 ); + my $not_ref = ( !ref $e1 and !ref $e2 ); + + if( defined $e1 xor defined $e2 ) { + $ok = 0; + } + elsif( !defined $e1 and !defined $e2 ) { + # Shortcut if they're both defined. + $ok = 1; + } + elsif( _dne($e1) xor _dne($e2) ) { + $ok = 0; + } + elsif( $same_ref and( $e1 eq $e2 ) ) { + $ok = 1; + } + elsif($not_ref) { + push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; + $ok = 0; + } + else { + if( $Refs_Seen{$e1} ) { + return $Refs_Seen{$e1} eq $e2; + } + else { + $Refs_Seen{$e1} = "$e2"; + } + + my $type = _type($e1); + $type = 'DIFFERENT' unless _type($e2) eq $type; + + if( $type eq 'DIFFERENT' ) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; + $ok = 0; + } + elsif( $type eq 'ARRAY' ) { + $ok = _eq_array( $e1, $e2 ); + } + elsif( $type eq 'HASH' ) { + $ok = _eq_hash( $e1, $e2 ); + } + elsif( $type eq 'REF' ) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $$e1, $$e2 ); + pop @Data_Stack if $ok; + } + elsif( $type eq 'SCALAR' ) { + push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; + $ok = _deep_check( $$e1, $$e2 ); + pop @Data_Stack if $ok; + } + elsif($type) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; + $ok = 0; + } + else { + _whoa( 1, "No type in _deep_check" ); + } + } + } + + return $ok; +} + +sub _whoa { + my( $check, $desc ) = @_; + if($check) { + die <<"WHOA"; +WHOA! $desc +This should never happen! Please contact the author immediately! +WHOA + } +} + +=item B<eq_hash> + + my $is_eq = eq_hash(\%got, \%expected); + +Determines if the two hashes contain the same keys and values. This +is a deep check. + +=cut + +sub eq_hash { + local @Data_Stack = (); + return _deep_check(@_); +} + +sub _eq_hash { + my( $a1, $a2 ) = @_; + + if( grep _type($_) ne 'HASH', $a1, $a2 ) { + warn "eq_hash passed a non-hash ref"; + return 0; + } + + return 1 if $a1 eq $a2; + + my $ok = 1; + my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; + foreach my $k ( keys %$bigger ) { + my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; + my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; + + push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); + pop @Data_Stack if $ok; + + last unless $ok; + } + + return $ok; +} + +=item B<eq_set> + + my $is_eq = eq_set(\@got, \@expected); + +Similar to eq_array(), except the order of the elements is B<not> +important. This is a deep check, but the irrelevancy of order only +applies to the top level. + + ok( eq_set(\@got, \@expected) ); + +Is better written: + + is_deeply( [sort @got], [sort @expected] ); + +B<NOTE> By historical accident, this is not a true set comparison. +While the order of elements does not matter, duplicate elements do. + +B<NOTE> eq_set() does not know how to deal with references at the top +level. The following is an example of a comparison which might not work: + + eq_set([\1, \2], [\2, \1]); + +L<Test::Deep> contains much better set comparison functions. + +=cut + +sub eq_set { + my( $a1, $a2 ) = @_; + return 0 unless @$a1 == @$a2; + + no warnings 'uninitialized'; + + # It really doesn't matter how we sort them, as long as both arrays are + # sorted with the same algorithm. + # + # Ensure that references are not accidentally treated the same as a + # string containing the reference. + # + # Have to inline the sort routine due to a threading/sort bug. + # See [rt.cpan.org 6782] + # + # I don't know how references would be sorted so we just don't sort + # them. This means eq_set doesn't really work with refs. + return eq_array( + [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], + [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], + ); +} + +=back + + +=head2 Extending and Embedding Test::More + +Sometimes the Test::More interface isn't quite enough. Fortunately, +Test::More is built on top of Test::Builder which provides a single, +unified backend for any test library to use. This means two test +libraries which both use Test::Builder B<can be used together in the +same program>. + +If you simply want to do a little tweaking of how the tests behave, +you can access the underlying Test::Builder object like so: + +=over 4 + +=item B<builder> + + my $test_builder = Test::More->builder; + +Returns the Test::Builder object underlying Test::More for you to play +with. + + +=back + + +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +B<NOTE> This behavior may go away in future versions. + + +=head1 CAVEATS and NOTES + +=over 4 + +=item Backwards compatibility + +Test::More works with Perls as old as 5.6.0. + + +=item utf8 / "Wide character in print" + +If you use utf8 or other non-ASCII characters with Test::More you +might get a "Wide character in print" warning. Using C<binmode +STDOUT, ":utf8"> will not fix it. Test::Builder (which powers +Test::More) duplicates STDOUT and STDERR. So any changes to them, +including changing their output disciplines, will not be seem by +Test::More. + +The work around is to change the filehandles used by Test::Builder +directly. + + my $builder = Test::More->builder; + binmode $builder->output, ":utf8"; + binmode $builder->failure_output, ":utf8"; + binmode $builder->todo_output, ":utf8"; + + +=item Overloaded objects + +String overloaded objects are compared B<as strings> (or in cmp_ok()'s +case, strings or numbers as appropriate to the comparison op). This +prevents Test::More from piercing an object's interface allowing +better blackbox testing. So if a function starts returning overloaded +objects instead of bare strings your tests won't notice the +difference. This is good. + +However, it does mean that functions like is_deeply() cannot be used to +test the internals of string overloaded objects. In this case I would +suggest L<Test::Deep> which contains more flexible testing functions for +complex data structures. + + +=item Threads + +Test::More will only be aware of threads if "use threads" has been done +I<before> Test::More is loaded. This is ok: + + use threads; + use Test::More; + +This may cause problems: + + use Test::More + use threads; + +5.8.1 and above are supported. Anything below that has too many bugs. + + +=item Test::Harness upgrade + +no_plan, todo and done_testing() depend on new Test::Harness features +and fixes. If you're going to distribute tests that use no_plan or +todo your end-users will have to upgrade Test::Harness to the latest +one on CPAN. If you avoid no_plan and TODO tests, the stock +Test::Harness will work fine. + +Installing Test::More should also upgrade Test::Harness. + +=back + + +=head1 HISTORY + +This is a case of convergent evolution with Joshua Pritikin's Test +module. I was largely unaware of its existence when I'd first +written my own ok() routines. This module exists because I can't +figure out how to easily wedge test names into Test's interface (along +with a few other problems). + +The goal here is to have a testing utility that's simple to learn, +quick to use and difficult to trip yourself up with while still +providing more flexibility than the existing Test.pm. As such, the +names of the most common routines are kept tiny, special cases and +magic side-effects are kept to a minimum. WYSIWYG. + + +=head1 SEE ALSO + +L<Test::Simple> if all this confuses you and you just want to write +some tests. You can upgrade to Test::More later (it's forward +compatible). + +L<Test::Harness> is the test runner and output interpreter for Perl. +It's the thing that powers C<make test> and where the C<prove> utility +comes from. + +L<Test::Legacy> tests written with Test.pm, the original testing +module, do not play well with other testing libraries. Test::Legacy +emulates the Test.pm interface and does play well with others. + +L<Test::Differences> for more ways to test complex data structures. +And it plays well with Test::More. + +L<Test::Class> is like xUnit but more perlish. + +L<Test::Deep> gives you more powerful complex data structure testing. + +L<Test::Inline> shows the idea of embedded testing. + +L<Bundle::Test> installs a whole bunch of useful test modules. + + +=head1 AUTHORS + +Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration +from Joshua Pritikin's Test module and lots of help from Barrie +Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and +the perl-qa gang. + + +=head1 BUGS + +See F<http://rt.cpan.org> to report and view bugs. + + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/schwern/test-more/>. + + +=head1 COPYRIGHT + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=cut + +1; diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm new file mode 100644 index 0000000000..48c72e27fc --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Simple.pm @@ -0,0 +1,214 @@ +package Test::Simple; + +use 5.004; + +use strict; + +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +use Test::Builder::Module; +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok); + +my $CLASS = __PACKAGE__; + +=head1 NAME + +Test::Simple - Basic utilities for writing tests. + +=head1 SYNOPSIS + + use Test::Simple tests => 1; + + ok( $foo eq $bar, 'foo is bar' ); + + +=head1 DESCRIPTION + +** If you are unfamiliar with testing B<read Test::Tutorial> first! ** + +This is an extremely simple, extremely basic module for writing tests +suitable for CPAN modules and other pursuits. If you wish to do more +complicated testing, use the Test::More module (a drop-in replacement +for this one). + +The basic unit of Perl testing is the ok. For each thing you want to +test your program will print out an "ok" or "not ok" to indicate pass +or fail. You do this with the ok() function (see below). + +The only other constraint is you must pre-declare how many tests you +plan to run. This is in case something goes horribly wrong during the +test and your test program aborts, or skips a test or whatever. You +do this like so: + + use Test::Simple tests => 23; + +You must have a plan. + + +=over 4 + +=item B<ok> + + ok( $foo eq $bar, $name ); + ok( $foo eq $bar ); + +ok() is given an expression (in this case C<$foo eq $bar>). If it's +true, the test passed. If it's false, it didn't. That's about it. + +ok() prints out either "ok" or "not ok" along with a test number (it +keeps track of that for you). + + # This produces "ok 1 - Hell not yet frozen over" (or not ok) + ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); + +If you provide a $name, that will be printed along with the "ok/not +ok" to make it easier to find your test when if fails (just search for +the name). It also makes it easier for the next guy to understand +what your test is for. It's highly recommended you use test names. + +All tests are run in scalar context. So this: + + ok( @stuff, 'I have some stuff' ); + +will do what you mean (fail if stuff is empty) + +=cut + +sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) + return $CLASS->builder->ok(@_); +} + +=back + +Test::Simple will start by printing number of tests run in the form +"1..M" (so "1..5" means you're going to run 5 tests). This strange +format lets Test::Harness know how many tests you plan on running in +case something goes horribly wrong. + +If all your tests passed, Test::Simple will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Simple +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +This module is by no means trying to be a complete testing system. +It's just to get you started. Once you're off the ground its +recommended you look at L<Test::More>. + + +=head1 EXAMPLE + +Here's an example of a simple .t file for the fictional Film module. + + use Test::Simple tests => 5; + + use Film; # What you're testing. + + my $btaste = Film->new({ Title => 'Bad Taste', + Director => 'Peter Jackson', + Rating => 'R', + NumExplodingSheep => 1 + }); + ok( defined($btaste) && ref $btaste eq 'Film, 'new() works' ); + + ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); + ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); + ok( $btaste->Rating eq 'R', 'Rating() get' ); + ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); + +It will produce output like this: + + 1..5 + ok 1 - new() works + ok 2 - Title() get + ok 3 - Director() get + not ok 4 - Rating() get + # Failed test 'Rating() get' + # in t/film.t at line 14. + ok 5 - NumExplodingSheep() get + # Looks like you failed 1 tests of 5 + +Indicating the Film::Rating() method is broken. + + +=head1 CAVEATS + +Test::Simple will only report a maximum of 254 failures in its exit +code. If this is a problem, you probably have a huge test script. +Split it into multiple files. (Otherwise blame the Unix folks for +using an unsigned short integer as the exit status). + +Because VMS's exit codes are much, much different than the rest of the +universe, and perl does horrible mangling to them that gets in my way, +it works like this on VMS. + + 0 SS$_NORMAL all tests successful + 4 SS$_ABORT something went wrong + +Unfortunately, I can't differentiate any further. + + +=head1 NOTES + +Test::Simple is B<explicitly> tested all the way back to perl 5.004. + +Test::Simple is thread-safe in perl 5.8.0 and up. + +=head1 HISTORY + +This module was conceived while talking with Tony Bowden in his +kitchen one night about the problems I was having writing some really +complicated feature into the new Testing module. He observed that the +main problem is not dealing with these edge cases but that people hate +to write tests B<at all>. What was needed was a dead simple module +that took all the hard work out of testing and was really, really easy +to learn. Paul Johnson simultaneously had this idea (unfortunately, +he wasn't in Tony's kitchen). This is it. + + +=head1 SEE ALSO + +=over 4 + +=item L<Test::More> + +More testing functions! Once you outgrow Test::Simple, look at +Test::More. Test::Simple is 100% forward compatible with Test::More +(i.e. you can just use Test::More instead of Test::Simple in your +programs and things will still work). + +=back + +Look in Test::More's SEE ALSO for more testing modules. + + +=head1 AUTHORS + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. + + +=head1 COPYRIGHT + +Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=cut + +1; diff --git a/cpan/Test-Simple/lib/Test/Tutorial.pod b/cpan/Test-Simple/lib/Test/Tutorial.pod new file mode 100644 index 0000000000..b730918c75 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Tutorial.pod @@ -0,0 +1,603 @@ +=head1 NAME + +Test::Tutorial - A tutorial about writing really basic tests + +=head1 DESCRIPTION + + +I<AHHHHHHH!!!! NOT TESTING! Anything but testing! +Beat me, whip me, send me to Detroit, but don't make +me write tests!> + +I<*sob*> + +I<Besides, I don't know how to write the damned things.> + + +Is this you? Is writing tests right up there with writing +documentation and having your fingernails pulled out? Did you open up +a test and read + + ######## We start with some black magic + +and decide that's quite enough for you? + +It's ok. That's all gone now. We've done all the black magic for +you. And here are the tricks... + + +=head2 Nuts and bolts of testing. + +Here's the most basic test program. + + #!/usr/bin/perl -w + + print "1..1\n"; + + print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n"; + +since 1 + 1 is 2, it prints: + + 1..1 + ok 1 + +What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1> +"The first test passed". And that's about all magic there is to +testing. Your basic unit of testing is the I<ok>. For each thing you +test, an C<ok> is printed. Simple. B<Test::Harness> interprets your test +results to determine if you succeeded or failed (more on that later). + +Writing all these print statements rapidly gets tedious. Fortunately, +there's B<Test::Simple>. It has one function, C<ok()>. + + #!/usr/bin/perl -w + + use Test::Simple tests => 1; + + ok( 1 + 1 == 2 ); + +and that does the same thing as the code above. C<ok()> is the backbone +of Perl testing, and we'll be using it instead of roll-your-own from +here on. If C<ok()> gets a true value, the test passes. False, it +fails. + + #!/usr/bin/perl -w + + use Test::Simple tests => 2; + ok( 1 + 1 == 2 ); + ok( 2 + 2 == 5 ); + +from that comes + + 1..2 + ok 1 + not ok 2 + # Failed test (test.pl at line 5) + # Looks like you failed 1 tests of 2. + +C<1..2> "I'm going to run two tests." This number is used to ensure +your test program ran all the way through and didn't die or skip some +tests. C<ok 1> "The first test passed." C<not ok 2> "The second test +failed". Test::Simple helpfully prints out some extra commentary about +your tests. + +It's not scary. Come, hold my hand. We're going to give an example +of testing a module. For our example, we'll be testing a date +library, B<Date::ICal>. It's on CPAN, so download a copy and follow +along. [2] + + +=head2 Where to start? + +This is the hardest part of testing, where do you start? People often +get overwhelmed at the apparent enormity of the task of testing a +whole module. Best place to start is at the beginning. Date::ICal is +an object-oriented module, and that means you start by making an +object. So we test C<new()>. + + #!/usr/bin/perl -w + + use Test::Simple tests => 2; + + use Date::ICal; + + my $ical = Date::ICal->new; # create an object + ok( defined $ical ); # check that we got something + ok( $ical->isa('Date::ICal') ); # and it's the right class + +run that and you should get: + + 1..2 + ok 1 + ok 2 + +congratulations, you've written your first useful test. + + +=head2 Names + +That output isn't terribly descriptive, is it? When you have two +tests you can figure out which one is #2, but what if you have 102? + +Each test can be given a little descriptive name as the second +argument to C<ok()>. + + use Test::Simple tests => 2; + + ok( defined $ical, 'new() returned something' ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + +So now you'd see... + + 1..2 + ok 1 - new() returned something + ok 2 - and it's the right class + + +=head2 Test the manual + +Simplest way to build up a decent testing suite is to just test what +the manual says it does. [3] Let's pull something out of the +L<Date::ICal/SYNOPSIS> and test that all its bits work. + + #!/usr/bin/perl -w + + use Test::Simple tests => 8; + + use Date::ICal; + + $ical = Date::ICal->new( year => 1964, month => 10, day => 16, + hour => 16, min => 12, sec => 47, + tz => '0530' ); + + ok( defined $ical, 'new() returned something' ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + ok( $ical->sec == 47, ' sec()' ); + ok( $ical->min == 12, ' min()' ); + ok( $ical->hour == 16, ' hour()' ); + ok( $ical->day == 17, ' day()' ); + ok( $ical->month == 10, ' month()' ); + ok( $ical->year == 1964, ' year()' ); + +run that and you get: + + 1..8 + ok 1 - new() returned something + ok 2 - and it's the right class + ok 3 - sec() + ok 4 - min() + ok 5 - hour() + not ok 6 - day() + # Failed test (- at line 16) + ok 7 - month() + ok 8 - year() + # Looks like you failed 1 tests of 8. + +Whoops, a failure! [4] Test::Simple helpfully lets us know on what line +the failure occurred, but not much else. We were supposed to get 17, +but we didn't. What did we get?? Dunno. We'll have to re-run the +test in the debugger or throw in some print statements to find out. + +Instead, we'll switch from B<Test::Simple> to B<Test::More>. B<Test::More> +does everything B<Test::Simple> does, and more! In fact, Test::More does +things I<exactly> the way Test::Simple does. You can literally swap +Test::Simple out and put Test::More in its place. That's just what +we're going to do. + +Test::More does more than Test::Simple. The most important difference +at this point is it provides more informative ways to say "ok". +Although you can write almost any test with a generic C<ok()>, it +can't tell you what went wrong. Instead, we'll use the C<is()> +function, which lets us declare that something is supposed to be the +same as something else: + + #!/usr/bin/perl -w + + use Test::More tests => 8; + + use Date::ICal; + + $ical = Date::ICal->new( year => 1964, month => 10, day => 16, + hour => 16, min => 12, sec => 47, + tz => '0530' ); + + ok( defined $ical, 'new() returned something' ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + is( $ical->sec, 47, ' sec()' ); + is( $ical->min, 12, ' min()' ); + is( $ical->hour, 16, ' hour()' ); + is( $ical->day, 17, ' day()' ); + is( $ical->month, 10, ' month()' ); + is( $ical->year, 1964, ' year()' ); + +"Is C<$ical-E<gt>sec> 47?" "Is C<$ical-E<gt>min> 12?" With C<is()> in place, +you get some more information + + 1..8 + ok 1 - new() returned something + ok 2 - and it's the right class + ok 3 - sec() + ok 4 - min() + ok 5 - hour() + not ok 6 - day() + # Failed test (- at line 16) + # got: '16' + # expected: '17' + ok 7 - month() + ok 8 - year() + # Looks like you failed 1 tests of 8. + +letting us know that C<$ical-E<gt>day> returned 16, but we expected 17. A +quick check shows that the code is working fine, we made a mistake +when writing up the tests. Just change it to: + + is( $ical->day, 16, ' day()' ); + +and everything works. + +So any time you're doing a "this equals that" sort of test, use C<is()>. +It even works on arrays. The test is always in scalar context, so you +can test how many elements are in a list this way. [5] + + is( @foo, 5, 'foo has 5 elements' ); + + +=head2 Sometimes the tests are wrong + +Which brings us to a very important lesson. Code has bugs. Tests are +code. Ergo, tests have bugs. A failing test could mean a bug in the +code, but don't discount the possibility that the test is wrong. + +On the flip side, don't be tempted to prematurely declare a test +incorrect just because you're having trouble finding the bug. +Invalidating a test isn't something to be taken lightly, and don't use +it as a cop out to avoid work. + + +=head2 Testing lots of values + +We're going to be wanting to test a lot of dates here, trying to trick +the code with lots of different edge cases. Does it work before 1970? +After 2038? Before 1904? Do years after 10,000 give it trouble? +Does it get leap years right? We could keep repeating the code above, +or we could set up a little try/expect loop. + + use Test::More tests => 32; + use Date::ICal; + + my %ICal_Dates = ( + # An ICal string And the year, month, date + # hour, minute and second we expect. + '19971024T120000' => # from the docs. + [ 1997, 10, 24, 12, 0, 0 ], + '20390123T232832' => # after the Unix epoch + [ 2039, 1, 23, 23, 28, 32 ], + '19671225T000000' => # before the Unix epoch + [ 1967, 12, 25, 0, 0, 0 ], + '18990505T232323' => # before the MacOS epoch + [ 1899, 5, 5, 23, 23, 23 ], + ); + + + while( my($ical_str, $expect) = each %ICal_Dates ) { + my $ical = Date::ICal->new( ical => $ical_str ); + + ok( defined $ical, "new(ical => '$ical_str')" ); + ok( $ical->isa('Date::ICal'), " and it's the right class" ); + + is( $ical->year, $expect->[0], ' year()' ); + is( $ical->month, $expect->[1], ' month()' ); + is( $ical->day, $expect->[2], ' day()' ); + is( $ical->hour, $expect->[3], ' hour()' ); + is( $ical->min, $expect->[4], ' min()' ); + is( $ical->sec, $expect->[5], ' sec()' ); + } + +So now we can test bunches of dates by just adding them to +C<%ICal_Dates>. Now that it's less work to test with more dates, you'll +be inclined to just throw more in as you think of them. +Only problem is, every time we add to that we have to keep adjusting +the C<use Test::More tests =E<gt> ##> line. That can rapidly get +annoying. There's two ways to make this work better. + +First, we can calculate the plan dynamically using the C<plan()> +function. + + use Test::More; + use Date::ICal; + + my %ICal_Dates = ( + ...same as before... + ); + + # For each key in the hash we're running 8 tests. + plan tests => keys %ICal_Dates * 8; + +Or to be even more flexible, we use C<no_plan>. This means we're just +running some tests, don't know how many. [6] + + use Test::More 'no_plan'; # instead of tests => 32 + +now we can just add tests and not have to do all sorts of math to +figure out how many we're running. + + +=head2 Informative names + +Take a look at this line here + + ok( defined $ical, "new(ical => '$ical_str')" ); + +we've added more detail about what we're testing and the ICal string +itself we're trying out to the name. So you get results like: + + ok 25 - new(ical => '19971024T120000') + ok 26 - and it's the right class + ok 27 - year() + ok 28 - month() + ok 29 - day() + ok 30 - hour() + ok 31 - min() + ok 32 - sec() + +if something in there fails, you'll know which one it was and that +will make tracking down the problem easier. So try to put a bit of +debugging information into the test names. + +Describe what the tests test, to make debugging a failed test easier +for you or for the next person who runs your test. + + +=head2 Skipping tests + +Poking around in the existing Date::ICal tests, I found this in +F<t/01sanity.t> [7] + + #!/usr/bin/perl -w + + use Test::More tests => 7; + use Date::ICal; + + # Make sure epoch time is being handled sanely. + my $t1 = Date::ICal->new( epoch => 0 ); + is( $t1->epoch, 0, "Epoch time of 0" ); + + # XXX This will only work on unix systems. + is( $t1->ical, '19700101Z', " epoch to ical" ); + + is( $t1->year, 1970, " year()" ); + is( $t1->month, 1, " month()" ); + is( $t1->day, 1, " day()" ); + + # like the tests above, but starting with ical instead of epoch + my $t2 = Date::ICal->new( ical => '19700101Z' ); + is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); + + is( $t2->epoch, 0, " and back to ICal" ); + +The beginning of the epoch is different on most non-Unix operating +systems [8]. Even though Perl smooths out the differences for the most +part, certain ports do it differently. MacPerl is one off the top of +my head. [9] We I<know> this will never work on MacOS. So rather than +just putting a comment in the test, we can explicitly say it's never +going to work and skip the test. + + use Test::More tests => 7; + use Date::ICal; + + # Make sure epoch time is being handled sanely. + my $t1 = Date::ICal->new( epoch => 0 ); + is( $t1->epoch, 0, "Epoch time of 0" ); + + SKIP: { + skip('epoch to ICal not working on MacOS', 6) + if $^O eq 'MacOS'; + + is( $t1->ical, '19700101Z', " epoch to ical" ); + + is( $t1->year, 1970, " year()" ); + is( $t1->month, 1, " month()" ); + is( $t1->day, 1, " day()" ); + + # like the tests above, but starting with ical instead of epoch + my $t2 = Date::ICal->new( ical => '19700101Z' ); + is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); + + is( $t2->epoch, 0, " and back to ICal" ); + } + +A little bit of magic happens here. When running on anything but +MacOS, all the tests run normally. But when on MacOS, C<skip()> causes +the entire contents of the SKIP block to be jumped over. It's never +run. Instead, it prints special output that tells Test::Harness that +the tests have been skipped. + + 1..7 + ok 1 - Epoch time of 0 + ok 2 # skip epoch to ICal not working on MacOS + ok 3 # skip epoch to ICal not working on MacOS + ok 4 # skip epoch to ICal not working on MacOS + ok 5 # skip epoch to ICal not working on MacOS + ok 6 # skip epoch to ICal not working on MacOS + ok 7 # skip epoch to ICal not working on MacOS + +This means your tests won't fail on MacOS. This means less emails +from MacPerl users telling you about failing tests that you know will +never work. You've got to be careful with skip tests. These are for +tests which don't work and I<never will>. It is not for skipping +genuine bugs (we'll get to that in a moment). + +The tests are wholly and completely skipped. [10] This will work. + + SKIP: { + skip("I don't wanna die!"); + + die, die, die, die, die; + } + + +=head2 Todo tests + +Thumbing through the Date::ICal man page, I came across this: + + ical + + $ical_string = $ical->ical; + + Retrieves, or sets, the date on the object, using any + valid ICal date/time string. + +"Retrieves or sets". Hmmm, didn't see a test for using C<ical()> to set +the date in the Date::ICal test suite. So I'll write one. + + use Test::More tests => 1; + use Date::ICal; + + my $ical = Date::ICal->new; + $ical->ical('20201231Z'); + is( $ical->ical, '20201231Z', 'Setting via ical()' ); + +run that and I get + + 1..1 + not ok 1 - Setting via ical() + # Failed test (- at line 6) + # got: '20010814T233649Z' + # expected: '20201231Z' + # Looks like you failed 1 tests of 1. + +Whoops! Looks like it's unimplemented. Let's assume we don't have +the time to fix this. [11] Normally, you'd just comment out the test +and put a note in a todo list somewhere. Instead, we're going to +explicitly state "this test will fail" by wrapping it in a C<TODO> block. + + use Test::More tests => 1; + + TODO: { + local $TODO = 'ical($ical) not yet implemented'; + + my $ical = Date::ICal->new; + $ical->ical('20201231Z'); + + is( $ical->ical, '20201231Z', 'Setting via ical()' ); + } + +Now when you run, it's a little different: + + 1..1 + not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented + # got: '20010822T201551Z' + # expected: '20201231Z' + +Test::More doesn't say "Looks like you failed 1 tests of 1". That '# +TODO' tells Test::Harness "this is supposed to fail" and it treats a +failure as a successful test. So you can write tests even before +you've fixed the underlying code. + +If a TODO test passes, Test::Harness will report it "UNEXPECTEDLY +SUCCEEDED". When that happens, you simply remove the TODO block with +C<local $TODO> and turn it into a real test. + + +=head2 Testing with taint mode. + +Taint mode is a funny thing. It's the globalest of all global +features. Once you turn it on, it affects I<all> code in your program +and I<all> modules used (and all the modules they use). If a single +piece of code isn't taint clean, the whole thing explodes. With that +in mind, it's very important to ensure your module works under taint +mode. + +It's very simple to have your tests run under taint mode. Just throw +a C<-T> into the C<#!> line. Test::Harness will read the switches +in C<#!> and use them to run your tests. + + #!/usr/bin/perl -Tw + + ...test normally here... + +So when you say C<make test> it will be run with taint mode and +warnings on. + + +=head1 FOOTNOTES + +=over 4 + +=item 1 + +The first number doesn't really mean anything, but it has to be 1. +It's the second number that's important. + +=item 2 + +For those following along at home, I'm using version 1.31. It has +some bugs, which is good -- we'll uncover them with our tests. + +=item 3 + +You can actually take this one step further and test the manual +itself. Have a look at B<Test::Inline> (formerly B<Pod::Tests>). + +=item 4 + +Yes, there's a mistake in the test suite. What! Me, contrived? + +=item 5 + +We'll get to testing the contents of lists later. + +=item 6 + +But what happens if your test program dies halfway through?! Since we +didn't say how many tests we're going to run, how can we know it +failed? No problem, Test::More employs some magic to catch that death +and turn the test into a failure, even if every test passed up to that +point. + +=item 7 + +I cleaned it up a little. + +=item 8 + +Most Operating Systems record time as the number of seconds since a +certain date. This date is the beginning of the epoch. Unix's starts +at midnight January 1st, 1970 GMT. + +=item 9 + +MacOS's epoch is midnight January 1st, 1904. VMS's is midnight, +November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a +problem. + +=item 10 + +As long as the code inside the SKIP block at least compiles. Please +don't ask how. No, it's not a filter. + +=item 11 + +Do NOT be tempted to use TODO tests as a way to avoid fixing simple +bugs! + +=back + +=head1 AUTHORS + +Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers! + +=head1 COPYRIGHT + +Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. + +This documentation is free; you can redistribute it and/or modify it +under the same terms as Perl itself. + +Irrespective of its distribution, all code examples in these files +are hereby placed into the public domain. You are permitted and +encouraged to use this code in your own programs for fun +or for profit as you see fit. A simple comment in the code giving +credit would be courteous but is not required. + +=cut diff --git a/cpan/Test-Simple/t/00test_harness_check.t b/cpan/Test-Simple/t/00test_harness_check.t new file mode 100644 index 0000000000..3ff4a13c63 --- /dev/null +++ b/cpan/Test-Simple/t/00test_harness_check.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w + +# A test to make sure the new Test::Harness was installed properly. + +use Test::More; +plan tests => 1; + +my $TH_Version = 2.03; + +require Test::Harness; +unless( cmp_ok( eval $Test::Harness::VERSION, '>=', $TH_Version, "T::H version" ) ) { + diag <<INSTRUCTIONS; + +Test::Simple/More/Builder has features which depend on a version of +Test::Harness greater than $TH_Version. You have $Test::Harness::VERSION. +Please install a new version from CPAN. + +If you've already tried to upgrade Test::Harness and still get this +message, the new version may be "shadowed" by the old. Check the +output of Test::Harness's "make install" for "## Differing version" +messages. You can delete the old version by running +"make install UNINST=1". + +INSTRUCTIONS +} + diff --git a/cpan/Test-Simple/t/BEGIN_require_ok.t b/cpan/Test-Simple/t/BEGIN_require_ok.t new file mode 100644 index 0000000000..733d0bb861 --- /dev/null +++ b/cpan/Test-Simple/t/BEGIN_require_ok.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +# Fixed a problem with BEGIN { use_ok or require_ok } silently failing when there's no +# plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak. + +use strict; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More; + +my $result; +BEGIN { + $result = require_ok("strict"); +} + +ok $result, "require_ok ran"; + +done_testing(2); diff --git a/cpan/Test-Simple/t/BEGIN_use_ok.t b/cpan/Test-Simple/t/BEGIN_use_ok.t new file mode 100644 index 0000000000..476badf7a2 --- /dev/null +++ b/cpan/Test-Simple/t/BEGIN_use_ok.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w + +# [rt.cpan.org 28345] +# +# A use_ok() inside a BEGIN block lacking a plan would be silently ignored. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More; + +my $result; +BEGIN { + $result = use_ok("strict"); +} + +ok( $result, "use_ok() ran" ); +done_testing(2); + diff --git a/cpan/Test-Simple/t/Builder/Builder.t b/cpan/Test-Simple/t/Builder/Builder.t new file mode 100644 index 0000000000..a5bfd155a6 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/Builder.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::Builder; +my $Test = Test::Builder->new; + +$Test->plan( tests => 7 ); + +my $default_lvl = $Test->level; +$Test->level(0); + +$Test->ok( 1, 'compiled and new()' ); +$Test->ok( $default_lvl == 1, 'level()' ); + +$Test->is_eq('foo', 'foo', 'is_eq'); +$Test->is_num('23.0', '23', 'is_num'); + +$Test->is_num( $Test->current_test, 4, 'current_test() get' ); + +my $test_num = $Test->current_test + 1; +$Test->current_test( $test_num ); +print "ok $test_num - current_test() set\n"; + +$Test->ok( 1, 'counter still good' ); diff --git a/cpan/Test-Simple/t/Builder/carp.t b/cpan/Test-Simple/t/Builder/carp.t new file mode 100644 index 0000000000..e89eeebfb9 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/carp.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + + +use Test::More tests => 3; +use Test::Builder; + +my $tb = Test::Builder->create; +sub foo { $tb->croak("foo") } +sub bar { $tb->carp("bar") } + +eval { foo() }; +is $@, sprintf "foo at %s line %s.\n", $0, __LINE__ - 1; + +eval { $tb->croak("this") }; +is $@, sprintf "this at %s line %s.\n", $0, __LINE__ - 1; + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { + $warning .= join '', @_; + }; + + bar(); + is $warning, sprintf "bar at %s line %s.\n", $0, __LINE__ - 1; +} diff --git a/cpan/Test-Simple/t/Builder/create.t b/cpan/Test-Simple/t/Builder/create.t new file mode 100644 index 0000000000..d584b30955 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/create.t @@ -0,0 +1,40 @@ +#!/usr/bin/perl -w + +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More tests => 7; +use Test::Builder; +use Test::Builder::NoOutput; + +my $more_tb = Test::More->builder; +isa_ok $more_tb, 'Test::Builder'; + +is $more_tb, Test::More->builder, 'create does not interfere with ->builder'; +is $more_tb, Test::Builder->new, ' does not interfere with ->new'; + +{ + my $new_tb = Test::Builder::NoOutput->create; + + isa_ok $new_tb, 'Test::Builder'; + isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object'; + + $new_tb->plan(tests => 1); + $new_tb->ok(1, "a test"); + + is $new_tb->read, <<'OUT'; +1..1 +ok 1 - a test +OUT +} + +pass("Changing output() of new TB doesn't interfere with singleton"); diff --git a/cpan/Test-Simple/t/Builder/current_test.t b/cpan/Test-Simple/t/Builder/current_test.t new file mode 100644 index 0000000000..edd201c0e9 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/current_test.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Dave Rolsky found a bug where if current_test() is used and no +# tests are run via Test::Builder it will blow up. + +use Test::Builder; +$TB = Test::Builder->new; +$TB->plan(tests => 2); +print "ok 1\n"; +print "ok 2\n"; +$TB->current_test(2); diff --git a/cpan/Test-Simple/t/Builder/current_test_without_plan.t b/cpan/Test-Simple/t/Builder/current_test_without_plan.t new file mode 100644 index 0000000000..31f9589977 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/current_test_without_plan.t @@ -0,0 +1,16 @@ +#!/usr/bin/perl -w + +# Test that current_test() will work without a declared plan. + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->current_test(2); +print <<'END'; +ok 1 +ok 2 +END + +$tb->ok(1, "Third test"); + +$tb->done_testing(3); diff --git a/cpan/Test-Simple/t/Builder/details.t b/cpan/Test-Simple/t/Builder/details.t new file mode 100644 index 0000000000..05d4828b4d --- /dev/null +++ b/cpan/Test-Simple/t/Builder/details.t @@ -0,0 +1,104 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More; +use Test::Builder; +my $Test = Test::Builder->new; + +$Test->plan( tests => 9 ); +$Test->level(0); + +my @Expected_Details; + +$Test->is_num( scalar $Test->summary(), 0, 'no tests yet, no summary' ); +push @Expected_Details, { 'ok' => 1, + actual_ok => 1, + name => 'no tests yet, no summary', + type => '', + reason => '' + }; + +# Inline TODO tests will confuse pre 1.20 Test::Harness, so we +# should just avoid the problem and not print it out. +my $start_test = $Test->current_test + 1; + +my $output = ''; +$Test->output(\$output); +$Test->todo_output(\$output); + +SKIP: { + $Test->skip( 'just testing skip' ); +} +push @Expected_Details, { 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => 'just testing skip', + }; + +TODO: { + local $TODO = 'i need a todo'; + $Test->ok( 0, 'a test to todo!' ); + + push @Expected_Details, { 'ok' => 1, + actual_ok => 0, + name => 'a test to todo!', + type => 'todo', + reason => 'i need a todo', + }; + + $Test->todo_skip( 'i need both' ); +} +push @Expected_Details, { 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => 'i need both' + }; + +for ($start_test..$Test->current_test) { print "ok $_\n" } +$Test->reset_outputs; + +$Test->is_num( scalar $Test->summary(), 4, 'summary' ); +push @Expected_Details, { 'ok' => 1, + actual_ok => 1, + name => 'summary', + type => '', + reason => '', + }; + +$Test->current_test(6); +print "ok 6 - current_test incremented\n"; +push @Expected_Details, { 'ok' => 1, + actual_ok => undef, + name => undef, + type => 'unknown', + reason => 'incrementing test number', + }; + +my @details = $Test->details(); +$Test->is_num( scalar @details, 6, + 'details() should return a list of all test details'); + +$Test->level(1); +is_deeply( \@details, \@Expected_Details ); + + +# This test has to come last because it thrashes the test details. +{ + my $curr_test = $Test->current_test; + $Test->current_test(4); + my @details = $Test->details(); + + $Test->current_test($curr_test); + $Test->is_num( scalar @details, 4 ); +} diff --git a/cpan/Test-Simple/t/Builder/done_testing.t b/cpan/Test-Simple/t/Builder/done_testing.t new file mode 100644 index 0000000000..14a8f918b0 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/done_testing.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->level(0); + +$tb->ok(1, "testing done_testing() with no arguments"); +$tb->ok(1, " another test so we're not testing just one"); +$tb->done_testing(); diff --git a/cpan/Test-Simple/t/Builder/done_testing_double.t b/cpan/Test-Simple/t/Builder/done_testing_double.t new file mode 100644 index 0000000000..3a0bae247b --- /dev/null +++ b/cpan/Test-Simple/t/Builder/done_testing_double.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl -w + +use strict; +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::Builder; +use Test::Builder::NoOutput; + +my $tb = Test::Builder::NoOutput->create; + +{ + # Normalize test output + local $ENV{HARNESS_ACTIVE}; + + $tb->ok(1); + $tb->ok(1); + $tb->ok(1); + +#line 24 + $tb->done_testing(3); + $tb->done_testing; + $tb->done_testing; +} + +my $Test = Test::Builder->new; +$Test->plan( tests => 1 ); +$Test->level(0); +$Test->is_eq($tb->read, <<"END", "multiple done_testing"); +ok 1 +ok 2 +ok 3 +1..3 +not ok 4 - done_testing() was already called at $0 line 24 +# Failed test 'done_testing() was already called at $0 line 24' +# at $0 line 25. +not ok 5 - done_testing() was already called at $0 line 24 +# Failed test 'done_testing() was already called at $0 line 24' +# at $0 line 26. +END diff --git a/cpan/Test-Simple/t/Builder/done_testing_plan_mismatch.t b/cpan/Test-Simple/t/Builder/done_testing_plan_mismatch.t new file mode 100644 index 0000000000..8208635359 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/done_testing_plan_mismatch.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl -w + +# What if there's a plan and done_testing but they don't match? + +use strict; +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::Builder; +use Test::Builder::NoOutput; + +my $tb = Test::Builder::NoOutput->create; + +{ + # Normalize test output + local $ENV{HARNESS_ACTIVE}; + + $tb->plan( tests => 3 ); + $tb->ok(1); + $tb->ok(1); + $tb->ok(1); + +#line 24 + $tb->done_testing(2); +} + +my $Test = Test::Builder->new; +$Test->plan( tests => 1 ); +$Test->level(0); +$Test->is_eq($tb->read, <<"END"); +1..3 +ok 1 +ok 2 +ok 3 +not ok 4 - planned to run 3 but done_testing() expects 2 +# Failed test 'planned to run 3 but done_testing() expects 2' +# at $0 line 24. +END diff --git a/cpan/Test-Simple/t/Builder/done_testing_with_no_plan.t b/cpan/Test-Simple/t/Builder/done_testing_with_no_plan.t new file mode 100644 index 0000000000..ff5f40c197 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/done_testing_with_no_plan.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->plan( "no_plan" ); +$tb->ok(1); +$tb->ok(1); +$tb->done_testing(2); diff --git a/cpan/Test-Simple/t/Builder/done_testing_with_number.t b/cpan/Test-Simple/t/Builder/done_testing_with_number.t new file mode 100644 index 0000000000..c21458f54e --- /dev/null +++ b/cpan/Test-Simple/t/Builder/done_testing_with_number.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->level(0); + +$tb->ok(1, "testing done_testing() with no arguments"); +$tb->ok(1, " another test so we're not testing just one"); +$tb->done_testing(2); diff --git a/cpan/Test-Simple/t/Builder/done_testing_with_plan.t b/cpan/Test-Simple/t/Builder/done_testing_with_plan.t new file mode 100644 index 0000000000..c0a3d0f014 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/done_testing_with_plan.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->plan( tests => 2 ); +$tb->ok(1); +$tb->ok(1); +$tb->done_testing(2); diff --git a/cpan/Test-Simple/t/Builder/fork_with_new_stdout.t b/cpan/Test-Simple/t/Builder/fork_with_new_stdout.t new file mode 100644 index 0000000000..e38c1d08cb --- /dev/null +++ b/cpan/Test-Simple/t/Builder/fork_with_new_stdout.t @@ -0,0 +1,54 @@ +#!perl -w +use strict; +use warnings; +use IO::Pipe; +use Test::Builder; +use Config; + +my $b = Test::Builder->new; +$b->reset; + +my $Can_Fork = $Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config{useithreads} and + $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ + ); + +if( !$Can_Fork ) { + $b->plan('skip_all' => "This system cannot fork"); +} +else { + $b->plan('tests' => 2); +} + +my $pipe = IO::Pipe->new; +if ( my $pid = fork ) { + $pipe->reader; + $b->ok((<$pipe> =~ /FROM CHILD: ok 1/), "ok 1 from child"); + $b->ok((<$pipe> =~ /FROM CHILD: 1\.\.1/), "1..1 from child"); + waitpid($pid, 0); +} +else { + $pipe->writer; + my $pipe_fd = $pipe->fileno; + close STDOUT; + open(STDOUT, ">&$pipe_fd"); + my $b = Test::Builder->new; + $b->reset; + $b->no_plan; + $b->ok(1); +} + + +=pod +#actual +1..2 +ok 1 +1..1 +ok 1 +ok 2 +#expected +1..2 +ok 1 +ok 2 +=cut diff --git a/cpan/Test-Simple/t/Builder/has_plan.t b/cpan/Test-Simple/t/Builder/has_plan.t new file mode 100644 index 0000000000..d0be86a97a --- /dev/null +++ b/cpan/Test-Simple/t/Builder/has_plan.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib'); + } +} + +use strict; +use Test::Builder; + +my $unplanned; + +BEGIN { + $unplanned = 'oops'; + $unplanned = Test::Builder->new->has_plan; +}; + +use Test::More tests => 2; + +is($unplanned, undef, 'no plan yet defined'); +is(Test::Builder->new->has_plan, 2, 'has fixed plan'); diff --git a/cpan/Test-Simple/t/Builder/has_plan2.t b/cpan/Test-Simple/t/Builder/has_plan2.t new file mode 100644 index 0000000000..e13ea4af94 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/has_plan2.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More; + +BEGIN { + if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) { + plan skip_all => "Won't work with t/TEST"; + } +} + +use strict; +use Test::Builder; + +plan 'no_plan'; +is(Test::Builder->new->has_plan, 'no_plan', 'has no_plan'); diff --git a/cpan/Test-Simple/t/Builder/is_fh.t b/cpan/Test-Simple/t/Builder/is_fh.t new file mode 100644 index 0000000000..0eb3ec0b15 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/is_fh.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 11; +use TieOut; + +ok( !Test::Builder->is_fh("foo"), 'string is not a filehandle' ); +ok( !Test::Builder->is_fh(''), 'empty string' ); +ok( !Test::Builder->is_fh(undef), 'undef' ); + +ok( open(FILE, '>foo') ); +END { close FILE; 1 while unlink 'foo' } + +ok( Test::Builder->is_fh(*FILE) ); +ok( Test::Builder->is_fh(\*FILE) ); +ok( Test::Builder->is_fh(*FILE{IO}) ); + +tie *OUT, 'TieOut'; +ok( Test::Builder->is_fh(*OUT) ); +ok( Test::Builder->is_fh(\*OUT) ); + +SKIP: { + skip "*TIED_HANDLE{IO} doesn't work in this perl", 1 + unless defined *OUT{IO}; + ok( Test::Builder->is_fh(*OUT{IO}) ); +} + + +package Lying::isa; + +sub isa { + my $self = shift; + my $parent = shift; + + return 1 if $parent eq 'IO::Handle'; +} + +::ok( Test::Builder->is_fh(bless {}, "Lying::isa")); diff --git a/cpan/Test-Simple/t/Builder/maybe_regex.t b/cpan/Test-Simple/t/Builder/maybe_regex.t new file mode 100644 index 0000000000..d1927a56e5 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/maybe_regex.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 16; + +use Test::Builder; +my $Test = Test::Builder->new; + +my $r = $Test->maybe_regex(qr/^FOO$/i); +ok(defined $r, 'qr// detected'); +ok(('foo' =~ /$r/), 'qr// good match'); +ok(('bar' !~ /$r/), 'qr// bad match'); + +SKIP: { + skip "blessed regex checker added in 5.10", 3 if $] < 5.010; + + my $obj = bless qr/foo/, 'Wibble'; + my $re = $Test->maybe_regex($obj); + ok( defined $re, "blessed regex detected" ); + ok( ('foo' =~ /$re/), 'blessed qr/foo/ good match' ); + ok( ('bar' !~ /$re/), 'blessed qr/foo/ bad math' ); +} + +{ + my $r = $Test->maybe_regex('/^BAR$/i'); + ok(defined $r, '"//" detected'); + ok(('bar' =~ m/$r/), '"//" good match'); + ok(('foo' !~ m/$r/), '"//" bad match'); +}; + +{ + my $r = $Test->maybe_regex('not a regex'); + ok(!defined $r, 'non-regex detected'); +}; + + +{ + my $r = $Test->maybe_regex('/0/'); + ok(defined $r, 'non-regex detected'); + ok(('f00' =~ m/$r/), '"//" good match'); + ok(('b4r' !~ m/$r/), '"//" bad match'); +}; + + +{ + my $r = $Test->maybe_regex('m,foo,i'); + ok(defined $r, 'm,, detected'); + ok(('fOO' =~ m/$r/), '"//" good match'); + ok(('bar' !~ m/$r/), '"//" bad match'); +}; diff --git a/cpan/Test-Simple/t/Builder/no_diag.t b/cpan/Test-Simple/t/Builder/no_diag.t new file mode 100644 index 0000000000..6fa538a82e --- /dev/null +++ b/cpan/Test-Simple/t/Builder/no_diag.t @@ -0,0 +1,8 @@ +#!/usr/bin/perl -w + +use Test::More 'no_diag', tests => 2; + +pass('foo'); +diag('This should not be displayed'); + +is(Test::More->builder->no_diag, 1); diff --git a/cpan/Test-Simple/t/Builder/no_ending.t b/cpan/Test-Simple/t/Builder/no_ending.t new file mode 100644 index 0000000000..97e968e289 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/no_ending.t @@ -0,0 +1,21 @@ +use Test::Builder; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +BEGIN { + my $t = Test::Builder->new; + $t->no_ending(1); +} + +use Test::More tests => 3; + +# Normally, Test::More would yell that we ran too few tests, but we +# supressed the ending diagnostics. +pass; +print "ok 2\n"; +print "ok 3\n"; diff --git a/cpan/Test-Simple/t/Builder/no_header.t b/cpan/Test-Simple/t/Builder/no_header.t new file mode 100644 index 0000000000..93e6bec34c --- /dev/null +++ b/cpan/Test-Simple/t/Builder/no_header.t @@ -0,0 +1,21 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::Builder; + +# STDOUT must be unbuffered else our prints might come out after +# Test::More's. +$| = 1; + +BEGIN { + Test::Builder->new->no_header(1); +} + +use Test::More tests => 1; + +print "1..1\n"; +pass; diff --git a/cpan/Test-Simple/t/Builder/no_plan_at_all.t b/cpan/Test-Simple/t/Builder/no_plan_at_all.t new file mode 100644 index 0000000000..9029f6f6e7 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/no_plan_at_all.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl -w + +# Test what happens when no plan is delcared and done_testing() is not seen + +use strict; +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::Builder; +use Test::Builder::NoOutput; + +my $Test = Test::Builder->new; +$Test->level(0); +$Test->plan( tests => 1 ); + +my $tb = Test::Builder::NoOutput->create; + +{ + $tb->level(0); + $tb->ok(1, "just a test"); + $tb->ok(1, " and another"); + $tb->_ending; +} + +$Test->is_eq($tb->read, <<'END', "proper behavior when no plan is seen"); +ok 1 - just a test +ok 2 - and another +# Tests were run but no plan was declared and done_testing() was not seen. +END diff --git a/cpan/Test-Simple/t/Builder/ok_obj.t b/cpan/Test-Simple/t/Builder/ok_obj.t new file mode 100644 index 0000000000..8678dbff8d --- /dev/null +++ b/cpan/Test-Simple/t/Builder/ok_obj.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl -w + +# Testing to make sure Test::Builder doesn't accidentally store objects +# passed in as test arguments. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 4; + +package Foo; +my $destroyed = 0; +sub new { bless {}, shift } + +sub DESTROY { + $destroyed++; +} + +package main; + +for (1..3) { + ok(my $foo = Foo->new, 'created Foo object'); +} +is $destroyed, 3, "DESTROY called 3 times"; + diff --git a/cpan/Test-Simple/t/Builder/output.t b/cpan/Test-Simple/t/Builder/output.t new file mode 100644 index 0000000000..77e0e0bbb3 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/output.t @@ -0,0 +1,113 @@ +#!perl -w + +use strict; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} +chdir 't'; + +use Test::Builder; + +# The real Test::Builder +my $Test = Test::Builder->new; +$Test->plan( tests => 6 ); + + +# The one we're going to test. +my $tb = Test::Builder->create(); + +my $tmpfile = 'foo.tmp'; +END { 1 while unlink($tmpfile) } + +# Test output to a file +{ + my $out = $tb->output($tmpfile); + $Test->ok( defined $out ); + + print $out "hi!\n"; + close *$out; + + undef $out; + open(IN, $tmpfile) or die $!; + chomp(my $line = <IN>); + close IN; + + $Test->is_eq($line, 'hi!'); +} + + +# Test output to a filehandle +{ + open(FOO, ">>$tmpfile") or die $!; + my $out = $tb->output(\*FOO); + my $old = select *$out; + print "Hello!\n"; + close *$out; + undef $out; + select $old; + open(IN, $tmpfile) or die $!; + my @lines = <IN>; + close IN; + + $Test->like($lines[1], qr/Hello!/); +} + + +# Test output to a scalar ref +{ + my $scalar = ''; + my $out = $tb->output(\$scalar); + + print $out "Hey hey hey!\n"; + $Test->is_eq($scalar, "Hey hey hey!\n"); +} + + +# Test we can output to the same scalar ref +{ + my $scalar = ''; + my $out = $tb->output(\$scalar); + my $err = $tb->failure_output(\$scalar); + + print $out "To output "; + print $err "and beyond!"; + + $Test->is_eq($scalar, "To output and beyond!", "One scalar, two filehandles"); +} + + +# Ensure stray newline in name escaping works. +{ + my $fakeout = ''; + my $out = $tb->output(\$fakeout); + $tb->exported_to(__PACKAGE__); + $tb->no_ending(1); + $tb->plan(tests => 5); + + $tb->ok(1, "ok"); + $tb->ok(1, "ok\n"); + $tb->ok(1, "ok, like\nok"); + $tb->skip("wibble\nmoof"); + $tb->todo_skip("todo\nskip\n"); + + $Test->is_eq( $fakeout, <<OUTPUT ) || print STDERR $fakeout; +1..5 +ok 1 - ok +ok 2 - ok +# +ok 3 - ok, like +# ok +ok 4 # skip wibble +# moof +not ok 5 # TODO & SKIP todo +# skip +# +OUTPUT +} diff --git a/cpan/Test-Simple/t/Builder/reset.t b/cpan/Test-Simple/t/Builder/reset.t new file mode 100644 index 0000000000..6bff7fcf27 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/reset.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl -w + +# Test Test::Builder->reset; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} +chdir 't'; + + +use Test::Builder; +my $Test = Test::Builder->new; +my $tb = Test::Builder->create; + +# We'll need this later to know the outputs were reset +my %Original_Output; +$Original_Output{$_} = $tb->$_ for qw(output failure_output todo_output); + +# Alter the state of Test::Builder as much as possible. +my $output = ''; +$tb->output(\$output); +$tb->failure_output(\$output); +$tb->todo_output(\$output); + +$tb->plan(tests => 14); +$tb->level(0); + +$tb->ok(1, "Running a test to alter TB's state"); + +# This won't print since we just sent output off to oblivion. +$tb->ok(0, "And a failure for fun"); + +$Test::Builder::Level = 3; + +$tb->exported_to('Foofer'); + +$tb->use_numbers(0); +$tb->no_header(1); +$tb->no_ending(1); + + +# Now reset it. +$tb->reset; + + +$Test->ok( !defined $tb->exported_to, 'exported_to' ); +$Test->is_eq( $tb->expected_tests, 0, 'expected_tests' ); +$Test->is_eq( $tb->level, 1, 'level' ); +$Test->is_eq( $tb->use_numbers, 1, 'use_numbers' ); +$Test->is_eq( $tb->no_header, 0, 'no_header' ); +$Test->is_eq( $tb->no_ending, 0, 'no_ending' ); +$Test->is_eq( $tb->current_test, 0, 'current_test' ); +$Test->is_eq( scalar $tb->summary, 0, 'summary' ); +$Test->is_eq( scalar $tb->details, 0, 'details' ); +$Test->is_eq( fileno $tb->output, + fileno $Original_Output{output}, 'output' ); +$Test->is_eq( fileno $tb->failure_output, + fileno $Original_Output{failure_output}, 'failure_output' ); +$Test->is_eq( fileno $tb->todo_output, + fileno $Original_Output{todo_output}, 'todo_output' ); + +$tb->current_test(12); +$tb->level(0); +$tb->ok(1, 'final test to make sure output was reset'); + +$Test->current_test(13); +$Test->done_testing(13); diff --git a/cpan/Test-Simple/t/Builder/try.t b/cpan/Test-Simple/t/Builder/try.t new file mode 100644 index 0000000000..eeb3bcb1ab --- /dev/null +++ b/cpan/Test-Simple/t/Builder/try.t @@ -0,0 +1,42 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::More 'no_plan'; + +require Test::Builder; +my $tb = Test::Builder->new; + + +# Test that _try() has no effect on $@ and $! and is not effected by +# __DIE__ +{ + local $SIG{__DIE__} = sub { fail("DIE handler called: @_") }; + local $@ = 42; + local $! = 23; + + is $tb->_try(sub { 2 }), 2; + is $tb->_try(sub { return '' }), ''; + + is $tb->_try(sub { die; }), undef; + + is_deeply [$tb->_try(sub { die "Foo\n" })], [undef, "Foo\n"]; + + is $@, 42; + cmp_ok $!, '==', 23; +} + +ok !eval { + $tb->_try(sub { die "Died\n" }, die_on_fail => 1); +}; +is $@, "Died\n"; diff --git a/cpan/Test-Simple/t/More.t b/cpan/Test-Simple/t/More.t new file mode 100644 index 0000000000..21958cf2b6 --- /dev/null +++ b/cpan/Test-Simple/t/More.t @@ -0,0 +1,179 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = qw(../lib ../lib/Test/Simple/t/lib); + } +} + +use lib 't/lib'; +use Test::More tests => 53; + +# Make sure we don't mess with $@ or $!. Test at bottom. +my $Err = "this should not be touched"; +my $Errno = 42; +$@ = $Err; +$! = $Errno; + +use_ok('Dummy'); +is( $Dummy::VERSION, '0.01', 'use_ok() loads a module' ); +require_ok('Test::More'); + + +ok( 2 eq 2, 'two is two is two is two' ); +is( "foo", "foo", 'foo is foo' ); +isnt( "foo", "bar", 'foo isnt bar'); +isn't("foo", "bar", 'foo isn\'t bar'); + +#'# +like("fooble", '/^foo/', 'foo is like fooble'); +like("FooBle", '/foo/i', 'foo is like FooBle'); +like("/usr/local/pr0n/", '/^\/usr\/local/', 'regexes with slashes in like' ); + +unlike("fbar", '/^bar/', 'unlike bar'); +unlike("FooBle", '/foo/', 'foo is unlike FooBle'); +unlike("/var/local/pr0n/", '/^\/usr\/local/','regexes with slashes in unlike' ); + +my @foo = qw(foo bar baz); +unlike(@foo, '/foo/'); + +can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok + pass fail eq_array eq_hash eq_set)); +can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip + can_ok pass fail eq_array eq_hash eq_set)); + + +isa_ok(bless([], "Foo"), "Foo"); +isa_ok([], 'ARRAY'); +isa_ok(\42, 'SCALAR'); +{ + local %Bar::; + local @Foo::ISA = 'Bar'; + isa_ok( "Foo", "Bar" ); +} + + +# can_ok() & isa_ok should call can() & isa() on the given object, not +# just class, in case of custom can() +{ + local *Foo::can; + local *Foo::isa; + *Foo::can = sub { $_[0]->[0] }; + *Foo::isa = sub { $_[0]->[0] }; + my $foo = bless([0], 'Foo'); + ok( ! $foo->can('bar') ); + ok( ! $foo->isa('bar') ); + $foo->[0] = 1; + can_ok( $foo, 'blah'); + isa_ok( $foo, 'blah'); +} + + +pass('pass() passed'); + +ok( eq_array([qw(this that whatever)], [qw(this that whatever)]), + 'eq_array with simple arrays' ); +is @Test::More::Data_Stack, 0, '@Data_Stack not holding onto things'; + +ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}), + 'eq_hash with simple hashes' ); +is @Test::More::Data_Stack, 0; + +ok( eq_set([qw(this that whatever)], [qw(that whatever this)]), + 'eq_set with simple sets' ); +is @Test::More::Data_Stack, 0; + +my @complex_array1 = ( + [qw(this that whatever)], + {foo => 23, bar => 42}, + "moo", + "yarrow", + [qw(498 10 29)], + ); +my @complex_array2 = ( + [qw(this that whatever)], + {foo => 23, bar => 42}, + "moo", + "yarrow", + [qw(498 10 29)], + ); + +is_deeply( \@complex_array1, \@complex_array2, 'is_deeply with arrays' ); +ok( eq_array(\@complex_array1, \@complex_array2), + 'eq_array with complicated arrays' ); +ok( eq_set(\@complex_array1, \@complex_array2), + 'eq_set with complicated arrays' ); + +my @array1 = (qw(this that whatever), + {foo => 23, bar => 42} ); +my @array2 = (qw(this that whatever), + {foo => 24, bar => 42} ); + +ok( !eq_array(\@array1, \@array2), + 'eq_array with slightly different complicated arrays' ); +is @Test::More::Data_Stack, 0; + +ok( !eq_set(\@array1, \@array2), + 'eq_set with slightly different complicated arrays' ); +is @Test::More::Data_Stack, 0; + +my %hash1 = ( foo => 23, + bar => [qw(this that whatever)], + har => { foo => 24, bar => 42 }, + ); +my %hash2 = ( foo => 23, + bar => [qw(this that whatever)], + har => { foo => 24, bar => 42 }, + ); + +is_deeply( \%hash1, \%hash2, 'is_deeply with complicated hashes' ); +ok( eq_hash(\%hash1, \%hash2), 'eq_hash with complicated hashes'); + +%hash1 = ( foo => 23, + bar => [qw(this that whatever)], + har => { foo => 24, bar => 42 }, + ); +%hash2 = ( foo => 23, + bar => [qw(this tha whatever)], + har => { foo => 24, bar => 42 }, + ); + +ok( !eq_hash(\%hash1, \%hash2), + 'eq_hash with slightly different complicated hashes' ); +is @Test::More::Data_Stack, 0; + +is( Test::Builder->new, Test::More->builder, 'builder()' ); + + +cmp_ok(42, '==', 42, 'cmp_ok =='); +cmp_ok('foo', 'eq', 'foo', ' eq'); +cmp_ok(42.5, '<', 42.6, ' <'); +cmp_ok(0, '||', 1, ' ||'); + + +# Piers pointed out sometimes people override isa(). +{ + package Wibble; + sub isa { + my($self, $class) = @_; + return 1 if $class eq 'Wibblemeister'; + } + sub new { bless {} } +} +isa_ok( Wibble->new, 'Wibblemeister' ); + +my $sub = sub {}; +is_deeply( $sub, $sub, 'the same function ref' ); + +use Symbol; +my $glob = gensym; +is_deeply( $glob, $glob, 'the same glob' ); + +is_deeply( { foo => $sub, bar => [1, $glob] }, + { foo => $sub, bar => [1, $glob] } + ); + +# These two tests must remain at the end. +is( $@, $Err, '$@ untouched' ); +cmp_ok( $!, '==', $Errno, '$! untouched' ); diff --git a/cpan/Test-Simple/t/Tester/tbt_01basic.t b/cpan/Test-Simple/t/Tester/tbt_01basic.t new file mode 100644 index 0000000000..769a1c4729 --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_01basic.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 9; +use Test::More; + +ok(1,"This is a basic test"); + +test_out("ok 1 - tested"); +ok(1,"tested"); +test_test("captured okay on basic"); + +test_out("ok 1 - tested"); +ok(1,"tested"); +test_test("captured okay again without changing number"); + +ok(1,"test unrelated to Test::Builder::Tester"); + +test_out("ok 1 - one"); +test_out("ok 2 - two"); +ok(1,"one"); +ok(2,"two"); +test_test("multiple tests"); + +test_out("not ok 1 - should fail"); +test_err("# Failed test ($0 at line 28)"); +test_err("# got: 'foo'"); +test_err("# expected: 'bar'"); +is("foo","bar","should fail"); +test_test("testing failing"); + + +test_out("not ok 1"); +test_out("not ok 2"); +test_fail(+2); +test_fail(+1); +fail(); fail(); +test_test("testing failing on the same line with no name"); + + +test_out("not ok 1 - name"); +test_out("not ok 2 - name"); +test_fail(+2); +test_fail(+1); +fail("name"); fail("name"); +test_test("testing failing on the same line with the same name"); + + +test_out("not ok 1 - name # TODO Something"); +test_err("# Failed (TODO) test ($0 at line 52)"); +TODO: { + local $TODO = "Something"; + fail("name"); +} +test_test("testing failing with todo"); + diff --git a/cpan/Test-Simple/t/Tester/tbt_02fhrestore.t b/cpan/Test-Simple/t/Tester/tbt_02fhrestore.t new file mode 100644 index 0000000000..e37357171b --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_02fhrestore.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 4; +use Test::More; +use Symbol; + +# create temporary file handles that still point indirectly +# to the right place + +my $orig_o = gensym; +my $orig_t = gensym; +my $orig_f = gensym; + +tie *$orig_o, "My::Passthru", \*STDOUT; +tie *$orig_t, "My::Passthru", \*STDERR; +tie *$orig_f, "My::Passthru", \*STDERR; + +# redirect the file handles to somewhere else for a mo + +use Test::Builder; +my $t = Test::Builder->new(); + +$t->output($orig_o); +$t->failure_output($orig_f); +$t->todo_output($orig_t); + +# run a test + +test_out("ok 1 - tested"); +ok(1,"tested"); +test_test("standard test okay"); + +# now check that they were restored okay + +ok($orig_o == $t->output(), "output file reconnected"); +ok($orig_t == $t->todo_output(), "todo output file reconnected"); +ok($orig_f == $t->failure_output(), "failure output file reconnected"); + +##################################################################### + +package My::Passthru; + +sub PRINT { + my $self = shift; + my $handle = $self->[0]; + print $handle @_; +} + +sub TIEHANDLE { + my $class = shift; + my $self = [shift()]; + return bless $self, $class; +} + +sub READ {} +sub READLINE {} +sub GETC {} +sub FILENO {} diff --git a/cpan/Test-Simple/t/Tester/tbt_03die.t b/cpan/Test-Simple/t/Tester/tbt_03die.t new file mode 100644 index 0000000000..b9dba801eb --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_03die.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 1; +use Test::More; + +eval { + test_test("foo"); +}; +like($@, + "/Not testing\. You must declare output with a test function first\./", + "dies correctly on error"); + diff --git a/cpan/Test-Simple/t/Tester/tbt_04line_num.t b/cpan/Test-Simple/t/Tester/tbt_04line_num.t new file mode 100644 index 0000000000..9e8365acbf --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_04line_num.t @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +use Test::More tests => 3; +use Test::Builder::Tester; + +is(line_num(),6,"normal line num"); +is(line_num(-1),6,"line number minus one"); +is(line_num(+2),10,"line number plus two"); diff --git a/cpan/Test-Simple/t/Tester/tbt_05faildiag.t b/cpan/Test-Simple/t/Tester/tbt_05faildiag.t new file mode 100644 index 0000000000..59ad721240 --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_05faildiag.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 5; +use Test::More; + +# test_fail + +test_out("not ok 1 - one"); +test_fail(+1); +ok(0,"one"); + +test_out("not ok 2 - two"); +test_fail(+2); + +ok(0,"two"); + +test_test("test fail"); + +test_fail(+2); +test_out("not ok 1 - one"); +ok(0,"one"); +test_test("test_fail first"); + +# test_diag + +use Test::Builder; +my $test = new Test::Builder; + +test_diag("this is a test string","so is this"); +$test->diag("this is a test string\n", "so is this\n"); +test_test("test diag"); + +test_diag("this is a test string","so is this"); +$test->diag("this is a test string\n"); +$test->diag("so is this\n"); +test_test("test diag multi line"); + +test_diag("this is a test string"); +test_diag("so is this"); +$test->diag("this is a test string\n"); +$test->diag("so is this\n"); +test_test("test diag multiple"); + + diff --git a/cpan/Test-Simple/t/Tester/tbt_06errormess.t b/cpan/Test-Simple/t/Tester/tbt_06errormess.t new file mode 100644 index 0000000000..d8d8a0fead --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_06errormess.t @@ -0,0 +1,120 @@ +#!/usr/bin/perl -w + +use Test::More tests => 8; +use Symbol; +use Test::Builder; +use Test::Builder::Tester; + +use strict; + +# argh! now we need to test the thing we're testing. Basically we need +# to pretty much reimplement the whole code again. This is very +# annoying but can't be avoided. And onwards with the cut and paste + +# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING + +# create some private file handles +my $output_handle = gensym; +my $error_handle = gensym; + +# and tie them to this package +my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; +my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; + +# ooooh, use the test suite +my $t = Test::Builder->new; + +# remember the testing outputs +my $original_output_handle; +my $original_failure_handle; +my $original_todo_handle; +my $original_harness_env; +my $testing_num; + +sub start_testing +{ + # remember what the handles were set to + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); + $original_harness_env = $ENV{HARNESS_ACTIVE}; + + # switch out to our own handles + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($error_handle); + + $ENV{HARNESS_ACTIVE} = 0; + + # clear the expected list + $out->reset(); + $err->reset(); + + # remeber that we're testing + $testing_num = $t->current_test; + $t->current_test(0); +} + +# each test test is actually two tests. This is bad and wrong +# but makes blood come out of my ears if I don't at least simplify +# it a little this way + +sub my_test_test +{ + my $text = shift; + local $^W = 0; + + # reset the outputs + $t->output($original_output_handle); + $t->failure_output($original_failure_handle); + $t->todo_output($original_todo_handle); + $ENV{HARNESS_ACTIVE} = $original_harness_env; + + # reset the number of tests + $t->current_test($testing_num); + + # check we got the same values + my $got; + my $wanted; + + # stdout + $t->ok($out->check, "STDOUT $text"); + + # stderr + $t->ok($err->check, "STDERR $text"); +} + +#################################################################### +# Meta meta tests +#################################################################### + +# this is a quick test to check the hack that I've just implemented +# actually does a cut down version of Test::Builder::Tester + +start_testing(); +$out->expect("ok 1 - foo"); +pass("foo"); +my_test_test("basic meta meta test"); + +start_testing(); +$out->expect("not ok 1 - foo"); +$err->expect("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +my_test_test("basic meta meta test 2"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("ok 1 - foo"); +pass("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("not ok 1 - foo"); +test_err("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt2 "); + +#################################################################### diff --git a/cpan/Test-Simple/t/Tester/tbt_07args.t b/cpan/Test-Simple/t/Tester/tbt_07args.t new file mode 100644 index 0000000000..1b9393bdf4 --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_07args.t @@ -0,0 +1,215 @@ +#!/usr/bin/perl -w + +use Test::More tests => 18; +use Symbol; +use Test::Builder; +use Test::Builder::Tester; + +use strict; + +# argh! now we need to test the thing we're testing. Basically we need +# to pretty much reimplement the whole code again. This is very +# annoying but can't be avoided. And onwards with the cut and paste + +# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING + +# create some private file handles +my $output_handle = gensym; +my $error_handle = gensym; + +# and tie them to this package +my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; +my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; + +# ooooh, use the test suite +my $t = Test::Builder->new; + +# remember the testing outputs +my $original_output_handle; +my $original_failure_handle; +my $original_todo_handle; +my $testing_num; +my $original_harness_env; + +sub start_testing +{ + # remember what the handles were set to + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); + $original_harness_env = $ENV{HARNESS_ACTIVE}; + + # switch out to our own handles + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($error_handle); + + $ENV{HARNESS_ACTIVE} = 0; + + # clear the expected list + $out->reset(); + $err->reset(); + + # remeber that we're testing + $testing_num = $t->current_test; + $t->current_test(0); +} + +# each test test is actually two tests. This is bad and wrong +# but makes blood come out of my ears if I don't at least simplify +# it a little this way + +sub my_test_test +{ + my $text = shift; + local $^W = 0; + + # reset the outputs + $t->output($original_output_handle); + $t->failure_output($original_failure_handle); + $t->todo_output($original_todo_handle); + $ENV{HARNESS_ACTIVE} = $original_harness_env; + + # reset the number of tests + $t->current_test($testing_num); + + # check we got the same values + my $got; + my $wanted; + + # stdout + $t->ok($out->check, "STDOUT $text"); + + # stderr + $t->ok($err->check, "STDERR $text"); +} + +#################################################################### +# Meta meta tests +#################################################################### + +# this is a quick test to check the hack that I've just implemented +# actually does a cut down version of Test::Builder::Tester + +start_testing(); +$out->expect("ok 1 - foo"); +pass("foo"); +my_test_test("basic meta meta test"); + +start_testing(); +$out->expect("not ok 1 - foo"); +$err->expect("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +my_test_test("basic meta meta test 2"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("ok 1 - foo"); +pass("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("not ok 1 - foo"); +test_err("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt2 "); + +#################################################################### +# Actual meta tests +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("ok 1 - foo"); + +# the actual test function that we are testing +ok("1","foo"); + +# test the name +test_test(name => "bar"); + +# check that passed +my_test_test("meta test name"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("ok 1 - foo"); + +# the actual test function that we are testing +ok("1","foo"); + +# test the name +test_test(title => "bar"); + +# check that passed +my_test_test("meta test title"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("ok 1 - foo"); + +# the actual test function that we are testing +ok("1","foo"); + +# test the name +test_test(label => "bar"); + +# check that passed +my_test_test("meta test title"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("not ok 1 - foo this is wrong"); +test_fail(+3); + +# the actual test function that we are testing +ok("0","foo"); + +# test that we got what we expect, ignoring our is wrong +test_test(skip_out => 1, name => "bar"); + +# check that that passed +my_test_test("meta test skip_out"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("not ok 1 - foo"); +test_err("this is wrong"); + +# the actual test function that we are testing +ok("0","foo"); + +# test that we got what we expect, ignoring err is wrong +test_test(skip_err => 1, name => "bar"); + +# diagnostics failing out +# check that that passed +my_test_test("meta test skip_err"); + +#################################################################### diff --git a/cpan/Test-Simple/t/bad_plan.t b/cpan/Test-Simple/t/bad_plan.t new file mode 100644 index 0000000000..80e0e65bca --- /dev/null +++ b/cpan/Test-Simple/t/bad_plan.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::Builder; +my $Test = Test::Builder->new; +$Test->plan( tests => 2 ); +$Test->level(0); + +my $tb = Test::Builder->create; + +eval { $tb->plan(7); }; +$Test->like( $@, qr/^plan\(\) doesn't understand 7/, 'bad plan()' ) || + print STDERR "# $@"; + +eval { $tb->plan(wibble => 7); }; +$Test->like( $@, qr/^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) || + print STDERR "# $@"; diff --git a/cpan/Test-Simple/t/bail_out.t b/cpan/Test-Simple/t/bail_out.t new file mode 100644 index 0000000000..5cdc1f9969 --- /dev/null +++ b/cpan/Test-Simple/t/bail_out.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +my $Exit_Code; +BEGIN { + *CORE::GLOBAL::exit = sub { $Exit_Code = shift; }; +} + + +use Test::Builder; +use Test::More; + +my $output; +my $TB = Test::More->builder; +$TB->output(\$output); + +my $Test = Test::Builder->create; +$Test->level(0); + +$Test->plan(tests => 3); + +plan tests => 4; + +BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); + + +$Test->is_eq( $output, <<'OUT' ); +1..4 +Bail out! ROCKS FALL! EVERYONE DIES! +OUT + +$Test->is_eq( $Exit_Code, 255 ); + +$Test->ok( $Test->can("BAILOUT"), "Backwards compat" ); diff --git a/cpan/Test-Simple/t/buffer.t b/cpan/Test-Simple/t/buffer.t new file mode 100644 index 0000000000..6039e4a6f7 --- /dev/null +++ b/cpan/Test-Simple/t/buffer.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Ensure that intermixed prints to STDOUT and tests come out in the +# right order (ie. no buffering problems). + +use Test::More tests => 20; +my $T = Test::Builder->new; +$T->no_ending(1); + +for my $num (1..10) { + $tnum = $num * 2; + pass("I'm ok"); + $T->current_test($tnum); + print "ok $tnum - You're ok\n"; +} diff --git a/cpan/Test-Simple/t/c_flag.t b/cpan/Test-Simple/t/c_flag.t new file mode 100644 index 0000000000..a33963415e --- /dev/null +++ b/cpan/Test-Simple/t/c_flag.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +# Test::More should not print anything when Perl is only doing +# a compile as with the -c flag or B::Deparse or perlcc. + +# HARNESS_ACTIVE=1 was causing an error with -c +{ + local $ENV{HARNESS_ACTIVE} = 1; + local $^C = 1; + + require Test::More; + Test::More->import(tests => 1); + + fail("This should not show up"); +} + +Test::More->builder->no_ending(1); + +print "1..1\n"; +print "ok 1\n"; + diff --git a/cpan/Test-Simple/t/circular_data.t b/cpan/Test-Simple/t/circular_data.t new file mode 100644 index 0000000000..2fd819e1f4 --- /dev/null +++ b/cpan/Test-Simple/t/circular_data.t @@ -0,0 +1,71 @@ +#!/usr/bin/perl -w + +# Test is_deeply and friends with circular data structures [rt.cpan.org 7289] + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 11; + +my $a1 = [ 1, 2, 3 ]; +push @$a1, $a1; +my $a2 = [ 1, 2, 3 ]; +push @$a2, $a2; + +is_deeply $a1, $a2; +ok( eq_array ($a1, $a2) ); +ok( eq_set ($a1, $a2) ); + +my $h1 = { 1=>1, 2=>2, 3=>3 }; +$h1->{4} = $h1; +my $h2 = { 1=>1, 2=>2, 3=>3 }; +$h2->{4} = $h2; + +is_deeply $h1, $h2; +ok( eq_hash ($h1, $h2) ); + +my ($r, $s); + +$r = \$r; +$s = \$s; + +ok( eq_array ([$s], [$r]) ); + + +{ + # Classic set of circular scalar refs. + my($a,$b,$c); + $a = \$b; + $b = \$c; + $c = \$a; + + my($d,$e,$f); + $d = \$e; + $e = \$f; + $f = \$d; + + is_deeply( $a, $a ); + is_deeply( $a, $d ); +} + + +{ + # rt.cpan.org 11623 + # Make sure the circular ref checks don't get confused by a reference + # which is simply repeating. + my $a = {}; + my $b = {}; + my $c = {}; + + is_deeply( [$a, $a], [$b, $c] ); + is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } ); + is_deeply( [\$a, \$a], [\$b, \$c] ); +} diff --git a/cpan/Test-Simple/t/cmp_ok.t b/cpan/Test-Simple/t/cmp_ok.t new file mode 100644 index 0000000000..de1a7e634d --- /dev/null +++ b/cpan/Test-Simple/t/cmp_ok.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib', '../lib/Test/Simple/t/lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +require Test::Builder; +my $TB = Test::Builder->create; +$TB->level(0); + +sub try_cmp_ok { + my($left, $cmp, $right) = @_; + + my %expect; + $expect{ok} = eval "\$left $cmp \$right"; + $expect{error} = $@; + $expect{error} =~ s/ at .*\n?//; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $ok = cmp_ok($left, $cmp, $right, "cmp_ok"); + $TB->is_num(!!$ok, !!$expect{ok}, " right return"); + + my $diag = $err->read; + if( !$ok and $expect{error} ) { + $diag =~ s/^# //mg; + $TB->like( $diag, qr/\Q$expect{error}\E/, " expected error" ); + } + elsif( $ok ) { + $TB->is_eq( $diag, '', " passed without diagnostic" ); + } + else { + $TB->ok(1, " failed without diagnostic"); + } +} + + +use Test::More; +Test::More->builder->no_ending(1); + +require MyOverload; +my $cmp = Overloaded::Compare->new("foo", 42); +my $ify = Overloaded::Ify->new("bar", 23); + +my @Tests = ( + [1, '==', 1], + [1, '==', 2], + ["a", "eq", "b"], + ["a", "eq", "a"], + [1, "+", 1], + [1, "-", 1], + + [$cmp, '==', 42], + [$cmp, 'eq', "foo"], + [$ify, 'eq', "bar"], + [$ify, "==", 23], +); + +plan tests => scalar @Tests; +$TB->plan(tests => @Tests * 2); + +for my $test (@Tests) { + try_cmp_ok(@$test); +} diff --git a/cpan/Test-Simple/t/diag.t b/cpan/Test-Simple/t/diag.t new file mode 100644 index 0000000000..f5cb437d54 --- /dev/null +++ b/cpan/Test-Simple/t/diag.t @@ -0,0 +1,81 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + + +# Turn on threads here, if available, since this test tends to find +# lots of threading bugs. +use Config; +BEGIN { + if( $] >= 5.008001 && $Config{useithreads} ) { + require threads; + 'threads'->import; + } +} + + +use strict; + +use Test::Builder::NoOutput; +use Test::More tests => 7; + +my $test = Test::Builder::NoOutput->create; + +# Test diag() goes to todo_output() in a todo test. +{ + $test->todo_start(); + + $test->diag("a single line"); + is( $test->read('todo'), <<'DIAG', 'diag() with todo_output set' ); +# a single line +DIAG + + my $ret = $test->diag("multiple\n", "lines"); + is( $test->read('todo'), <<'DIAG', ' multi line' ); +# multiple +# lines +DIAG + ok( !$ret, 'diag returns false' ); + + $test->todo_end(); +} + + +# Test diagnostic formatting +{ + $test->diag("# foo"); + is( $test->read('err'), "# # foo\n", "diag() adds # even if there's one already" ); + + $test->diag("foo\n\nbar"); + is( $test->read('err'), <<'DIAG', " blank lines get escaped" ); +# foo +# +# bar +DIAG + + $test->diag("foo\n\nbar\n\n"); + is( $test->read('err'), <<'DIAG', " even at the end" ); +# foo +# +# bar +# +DIAG +} + + +# [rt.cpan.org 8392] diag(@list) emulates print +{ + $test->diag(qw(one two)); + + is( $test->read('err'), <<'DIAG' ); +# onetwo +DIAG +} diff --git a/cpan/Test-Simple/t/died.t b/cpan/Test-Simple/t/died.t new file mode 100644 index 0000000000..b4ee2fbbff --- /dev/null +++ b/cpan/Test-Simple/t/died.t @@ -0,0 +1,45 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 3); + + +package main; + +require Test::Simple; + +chdir 't'; +push @INC, '../t/lib/'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 1); +exit 250; + +END { + $TB->is_eq($out->read, <<OUT); +1..1 +OUT + + $TB->is_eq($err->read, <<ERR); +# Looks like your test exited with 250 before it could output anything. +ERR + + $TB->is_eq($?, 250, "exit code"); + + exit grep { !$_ } $TB->summary; +} diff --git a/cpan/Test-Simple/t/dont_overwrite_die_handler.t b/cpan/Test-Simple/t/dont_overwrite_die_handler.t new file mode 100644 index 0000000000..0657a06ca3 --- /dev/null +++ b/cpan/Test-Simple/t/dont_overwrite_die_handler.t @@ -0,0 +1,19 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Make sure this is in place before Test::More is loaded. +my $handler_called; +BEGIN { + $SIG{__DIE__} = sub { $handler_called++ }; +} + +use Test::More tests => 2; + +ok !eval { die }; +is $handler_called, 1, 'existing DIE handler not overridden'; diff --git a/cpan/Test-Simple/t/eq_set.t b/cpan/Test-Simple/t/eq_set.t new file mode 100644 index 0000000000..fbdc52db1f --- /dev/null +++ b/cpan/Test-Simple/t/eq_set.t @@ -0,0 +1,34 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} +chdir 't'; + +use strict; +use Test::More; + +plan tests => 4; + +# RT 3747 +ok( eq_set([1, 2, [3]], [[3], 1, 2]) ); +ok( eq_set([1,2,[3]], [1,[3],2]) ); + +# bugs.perl.org 36354 +my $ref = \2; +ok( eq_set( [$ref, "$ref", "$ref", $ref], + ["$ref", $ref, $ref, "$ref"] + ) ); + +TODO: { + local $TODO = q[eq_set() doesn't really handle references]; + + ok( eq_set( [\1, \2, \3], [\2, \3, \1] ) ); +} + diff --git a/cpan/Test-Simple/t/exit.t b/cpan/Test-Simple/t/exit.t new file mode 100644 index 0000000000..95661eef07 --- /dev/null +++ b/cpan/Test-Simple/t/exit.t @@ -0,0 +1,114 @@ +#!/usr/bin/perl -w + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +require Test::Builder; +my $TB = Test::Builder->create(); +$TB->level(0); + + +package main; + +use Cwd; +use File::Spec; + +my $Orig_Dir = cwd; + +my $Perl = File::Spec->rel2abs($^X); +if( $^O eq 'VMS' ) { + # VMS can't use its own $^X in a system call until almost 5.8 + $Perl = "MCR $^X" if $] < 5.007003; + + # Quiet noisy 'SYS$ABORT' + $Perl .= q{ -"I../lib"} if $ENV{PERL_CORE}; + $Perl .= q{ -"Mvmsish=hushed"}; +} + + +eval { require POSIX; &POSIX::WEXITSTATUS(0) }; +if( $@ ) { + *exitstatus = sub { $_[0] >> 8 }; +} +else { + *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) } +} + + +# Some OS' will alter the exit code to their own native sense... +# sometimes. Rather than deal with the exception we'll just +# build up the mapping. +print "# Building up a map of exit codes. May take a while.\n"; +my %Exit_Map; + +open my $fh, ">", "exit_map_test" or die $!; +print $fh <<'DONE'; +if ($^O eq 'VMS') { + require vmsish; + import vmsish qw(hushed); +} +my $exit = shift; +print "exit $exit\n"; +END { $? = $exit }; +DONE + +close $fh; +END { 1 while unlink "exit_map_test" } + +for my $exit (0..255) { + # This correctly emulates Test::Builder's behavior. + my $out = qx[$Perl exit_map_test $exit]; + $TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" ); + $Exit_Map{$exit} = exitstatus($?); +} +print "# Done.\n"; + + +my %Tests = ( + # File Exit Code + 'success.plx' => 0, + 'one_fail.plx' => 1, + 'two_fail.plx' => 2, + 'five_fail.plx' => 5, + 'extras.plx' => 2, + 'too_few.plx' => 255, + 'too_few_fail.plx' => 2, + 'death.plx' => 255, + 'last_minute_death.plx' => 255, + 'pre_plan_death.plx' => 'not zero', + 'death_in_eval.plx' => 0, + 'require.plx' => 0, + 'death_with_handler.plx' => 255, + 'exit.plx' => 1, + ); + +chdir 't'; +my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); +while( my($test_name, $exit_code) = each %Tests ) { + my $file = File::Spec->catfile($lib, $test_name); + my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file}); + my $actual_exit = exitstatus($wait_stat); + + if( $exit_code eq 'not zero' ) { + $TB->isnt_num( $actual_exit, $Exit_Map{0}, + "$test_name exited with $actual_exit ". + "(expected non-zero)"); + } + else { + $TB->is_num( $actual_exit, $Exit_Map{$exit_code}, + "$test_name exited with $actual_exit ". + "(expected $Exit_Map{$exit_code})"); + } +} + +$TB->done_testing( scalar keys(%Tests) + 256 ); + +# So any END block file cleanup works. +chdir $Orig_Dir; diff --git a/cpan/Test-Simple/t/explain.t b/cpan/Test-Simple/t/explain.t new file mode 100644 index 0000000000..cf2f550e95 --- /dev/null +++ b/cpan/Test-Simple/t/explain.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::More tests => 5; + +can_ok "main", "explain"; + +is_deeply [explain("foo")], ["foo"]; +is_deeply [explain("foo", "bar")], ["foo", "bar"]; + +# Avoid future dump formatting changes from breaking tests by just eval'ing +# the dump +is_deeply [map { eval $_ } explain([], {})], [[], {}]; + +is_deeply [map { eval $_ } explain(23, [42,91], 99)], [23, [42, 91], 99]; diff --git a/cpan/Test-Simple/t/extra.t b/cpan/Test-Simple/t/extra.t new file mode 100644 index 0000000000..57235be195 --- /dev/null +++ b/cpan/Test-Simple/t/extra.t @@ -0,0 +1,59 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 2); + + +package main; + +require Test::Simple; + +chdir 't'; +push @INC, '../t/lib/'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 3); + +#line 30 +ok(1, 'Foo'); +ok(0, 'Bar'); +ok(1, 'Yar'); +ok(1, 'Car'); +ok(0, 'Sar'); + +END { + $TB->is_eq($$out, <<OUT); +1..3 +ok 1 - Foo +not ok 2 - Bar +ok 3 - Yar +ok 4 - Car +not ok 5 - Sar +OUT + + $TB->is_eq($$err, <<ERR); +# Failed test 'Bar' +# at $0 line 31. +# Failed test 'Sar' +# at $0 line 34. +# Looks like you planned 3 tests but ran 5. +# Looks like you failed 2 tests of 5 run. +ERR + + exit 0; +} diff --git a/cpan/Test-Simple/t/extra_one.t b/cpan/Test-Simple/t/extra_one.t new file mode 100644 index 0000000000..d77404e15d --- /dev/null +++ b/cpan/Test-Simple/t/extra_one.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 2); + +sub is { $TB->is_eq(@_) } + + +package main; + +require Test::Simple; +Test::Simple->import(tests => 1); +ok(1); +ok(1); +ok(1); + +END { + My::Test::is($$out, <<OUT); +1..1 +ok 1 +ok 2 +ok 3 +OUT + + My::Test::is($$err, <<ERR); +# Looks like you planned 1 test but ran 3. +ERR + + # Prevent Test::Simple from existing with non-zero + exit 0; +} diff --git a/cpan/Test-Simple/t/fail-like.t b/cpan/Test-Simple/t/fail-like.t new file mode 100644 index 0000000000..0ea5fab3da --- /dev/null +++ b/cpan/Test-Simple/t/fail-like.t @@ -0,0 +1,74 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +# There was a bug with like() involving a qr// not failing properly. +# This tests against that. + +use strict; + + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 4); + + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + + +package main; + +require Test::More; +Test::More->import(tests => 1); + +{ + eval q{ like( "foo", qr/that/, 'is foo like that' ); }; + + $TB->is_eq($out->read, <<OUT, 'failing output'); +1..1 +not ok 1 - is foo like that +OUT + + my $err_re = <<ERR; +# Failed test 'is foo like that' +# at .* line 1\. +# 'foo' +# doesn't match '\\(\\?-xism:that\\)' +ERR + + $TB->like($err->read, qr/^$err_re$/, 'failing errors'); +} + +{ + # line 59 + like("foo", "not a regex"); + $TB->is_eq($out->read, <<OUT); +not ok 2 +OUT + + $TB->is_eq($err->read, <<OUT); +# Failed test at $0 line 59. +# 'not a regex' doesn't look much like a regex to me. +OUT + +} + +END { + # Test::More thinks it failed. Override that. + exit(scalar grep { !$_ } $TB->summary); +} diff --git a/cpan/Test-Simple/t/fail-more.t b/cpan/Test-Simple/t/fail-more.t new file mode 100644 index 0000000000..423e216488 --- /dev/null +++ b/cpan/Test-Simple/t/fail-more.t @@ -0,0 +1,511 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 78); + +sub like ($$;$) { + $TB->like(@_); +} + +sub is ($$;$) { + $TB->is_eq(@_); +} + +sub main::out_ok ($$) { + $TB->is_eq( $out->read, shift ); + $TB->is_eq( $err->read, shift ); +} + +sub main::out_like ($$) { + my($output, $failure) = @_; + + $TB->like( $out->read, qr/$output/ ); + $TB->like( $err->read, qr/$failure/ ); +} + + +package main; + +require Test::More; +our $TODO; +my $Total = 37; +Test::More->import(tests => $Total); +$out->read; # clear the plan from $out + +# This should all work in the presence of a __DIE__ handler. +local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); }; + + +my $tb = Test::More->builder; +$tb->use_numbers(0); + +my $Filename = quotemeta $0; + + +#line 38 +ok( 0, 'failing' ); +out_ok( <<OUT, <<ERR ); +not ok - failing +OUT +# Failed test 'failing' +# at $0 line 38. +ERR + + +#line 40 +is( "foo", "bar", 'foo is bar?'); +out_ok( <<OUT, <<ERR ); +not ok - foo is bar? +OUT +# Failed test 'foo is bar?' +# at $0 line 40. +# got: 'foo' +# expected: 'bar' +ERR + +#line 89 +is( undef, '', 'undef is empty string?'); +out_ok( <<OUT, <<ERR ); +not ok - undef is empty string? +OUT +# Failed test 'undef is empty string?' +# at $0 line 89. +# got: undef +# expected: '' +ERR + +#line 99 +is( undef, 0, 'undef is 0?'); +out_ok( <<OUT, <<ERR ); +not ok - undef is 0? +OUT +# Failed test 'undef is 0?' +# at $0 line 99. +# got: undef +# expected: '0' +ERR + +#line 110 +is( '', 0, 'empty string is 0?' ); +out_ok( <<OUT, <<ERR ); +not ok - empty string is 0? +OUT +# Failed test 'empty string is 0?' +# at $0 line 110. +# got: '' +# expected: '0' +ERR + +#line 121 +isnt("foo", "foo", 'foo isnt foo?' ); +out_ok( <<OUT, <<ERR ); +not ok - foo isnt foo? +OUT +# Failed test 'foo isnt foo?' +# at $0 line 121. +# got: 'foo' +# expected: anything else +ERR + +#line 132 +isn't("foo", "foo",'foo isn\'t foo?' ); +out_ok( <<OUT, <<ERR ); +not ok - foo isn't foo? +OUT +# Failed test 'foo isn\'t foo?' +# at $0 line 132. +# got: 'foo' +# expected: anything else +ERR + +#line 143 +isnt(undef, undef, 'undef isnt undef?'); +out_ok( <<OUT, <<ERR ); +not ok - undef isnt undef? +OUT +# Failed test 'undef isnt undef?' +# at $0 line 143. +# got: undef +# expected: anything else +ERR + +#line 154 +like( "foo", '/that/', 'is foo like that' ); +out_ok( <<OUT, <<ERR ); +not ok - is foo like that +OUT +# Failed test 'is foo like that' +# at $0 line 154. +# 'foo' +# doesn't match '/that/' +ERR + +#line 165 +unlike( "foo", '/foo/', 'is foo unlike foo' ); +out_ok( <<OUT, <<ERR ); +not ok - is foo unlike foo +OUT +# Failed test 'is foo unlike foo' +# at $0 line 165. +# 'foo' +# matches '/foo/' +ERR + +# Nick Clark found this was a bug. Fixed in 0.40. +# line 177 +like( "bug", '/(%)/', 'regex with % in it' ); +out_ok( <<OUT, <<ERR ); +not ok - regex with % in it +OUT +# Failed test 'regex with % in it' +# at $0 line 177. +# 'bug' +# doesn't match '/(%)/' +ERR + +#line 188 +fail('fail()'); +out_ok( <<OUT, <<ERR ); +not ok - fail() +OUT +# Failed test 'fail()' +# at $0 line 188. +ERR + +#line 197 +can_ok('Mooble::Hooble::Yooble', qw(this that)); +out_ok( <<OUT, <<ERR ); +not ok - Mooble::Hooble::Yooble->can(...) +OUT +# Failed test 'Mooble::Hooble::Yooble->can(...)' +# at $0 line 197. +# Mooble::Hooble::Yooble->can('this') failed +# Mooble::Hooble::Yooble->can('that') failed +ERR + +#line 208 +can_ok('Mooble::Hooble::Yooble', ()); +out_ok( <<OUT, <<ERR ); +not ok - Mooble::Hooble::Yooble->can(...) +OUT +# Failed test 'Mooble::Hooble::Yooble->can(...)' +# at $0 line 208. +# can_ok() called with no methods +ERR + +#line 218 +can_ok(undef, undef); +out_ok( <<OUT, <<ERR ); +not ok - ->can(...) +OUT +# Failed test '->can(...)' +# at $0 line 218. +# can_ok() called with empty class or reference +ERR + +#line 228 +can_ok([], "foo"); +out_ok( <<OUT, <<ERR ); +not ok - ARRAY->can('foo') +OUT +# Failed test 'ARRAY->can('foo')' +# at $0 line 228. +# ARRAY->can('foo') failed +ERR + +#line 238 +isa_ok(bless([], "Foo"), "Wibble"); +out_ok( <<OUT, <<ERR ); +not ok - The object isa Wibble +OUT +# Failed test 'The object isa Wibble' +# at $0 line 238. +# The object isn't a 'Wibble' it's a 'Foo' +ERR + +#line 248 +isa_ok(42, "Wibble", "My Wibble"); +out_ok( <<OUT, <<ERR ); +not ok - My Wibble isa Wibble +OUT +# Failed test 'My Wibble isa Wibble' +# at $0 line 248. +# My Wibble isn't a class or reference +ERR + +#line 258 +isa_ok(undef, "Wibble", "Another Wibble"); +out_ok( <<OUT, <<ERR ); +not ok - Another Wibble isa Wibble +OUT +# Failed test 'Another Wibble isa Wibble' +# at $0 line 258. +# Another Wibble isn't defined +ERR + +#line 268 +isa_ok([], "HASH"); +out_ok( <<OUT, <<ERR ); +not ok - The reference isa HASH +OUT +# Failed test 'The reference isa HASH' +# at $0 line 268. +# The reference isn't a 'HASH' it's a 'ARRAY' +ERR + +#line 278 +new_ok(undef); +out_like( <<OUT, <<ERR ); +not ok - new\\(\\) died +OUT +# Failed test 'new\\(\\) died' +# at $Filename line 278. +# Error was: Can't call method "new" on an undefined value at .* +ERR + +#line 288 +new_ok( "Does::Not::Exist" ); +out_like( <<OUT, <<ERR ); +not ok - new\\(\\) died +OUT +# Failed test 'new\\(\\) died' +# at $Filename line 288. +# Error was: Can't locate object method "new" via package "Does::Not::Exist" .* +ERR + + +{ package Foo; sub new { } } +{ package Bar; sub new { {} } } +{ package Baz; sub new { bless {}, "Wibble" } } + +#line 303 +new_ok( "Foo" ); +out_ok( <<OUT, <<ERR ); +not ok - The object isa Foo +OUT +# Failed test 'The object isa Foo' +# at $0 line 303. +# The object isn't defined +ERR + +# line 313 +new_ok( "Bar" ); +out_ok( <<OUT, <<ERR ); +not ok - The object isa Bar +OUT +# Failed test 'The object isa Bar' +# at $0 line 313. +# The object isn't a 'Bar' it's a 'HASH' +ERR + +#line 323 +new_ok( "Baz" ); +out_ok( <<OUT, <<ERR ); +not ok - The object isa Baz +OUT +# Failed test 'The object isa Baz' +# at $0 line 323. +# The object isn't a 'Baz' it's a 'Wibble' +ERR + +#line 333 +new_ok( "Baz", [], "no args" ); +out_ok( <<OUT, <<ERR ); +not ok - no args isa Baz +OUT +# Failed test 'no args isa Baz' +# at $0 line 333. +# no args isn't a 'Baz' it's a 'Wibble' +ERR + +#line 343 +cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' ); +out_ok( <<OUT, <<ERR ); +not ok - cmp_ok eq +OUT +# Failed test 'cmp_ok eq' +# at $0 line 343. +# got: 'foo' +# expected: 'bar' +ERR + +#line 354 +cmp_ok( 42.1, '==', 23, , ' ==' ); +out_ok( <<OUT, <<ERR ); +not ok - == +OUT +# Failed test ' ==' +# at $0 line 354. +# got: 42.1 +# expected: 23 +ERR + +#line 365 +cmp_ok( 42, '!=', 42 , ' !=' ); +out_ok( <<OUT, <<ERR ); +not ok - != +OUT +# Failed test ' !=' +# at $0 line 365. +# got: 42 +# expected: anything else +ERR + +#line 376 +cmp_ok( 1, '&&', 0 , ' &&' ); +out_ok( <<OUT, <<ERR ); +not ok - && +OUT +# Failed test ' &&' +# at $0 line 376. +# '1' +# && +# '0' +ERR + +# line 388 +cmp_ok( 42, 'eq', "foo", ' eq with numbers' ); +out_ok( <<OUT, <<ERR ); +not ok - eq with numbers +OUT +# Failed test ' eq with numbers' +# at $0 line 388. +# got: '42' +# expected: 'foo' +ERR + +{ + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; + +# line 404 + cmp_ok( 42, '==', "foo", ' == with strings' ); + out_ok( <<OUT, <<ERR ); +not ok - == with strings +OUT +# Failed test ' == with strings' +# at $0 line 404. +# got: 42 +# expected: foo +ERR + My::Test::like( + $warnings, + qr/^Argument "foo" isn't numeric in .* at cmp_ok \[from $Filename line 404\] line 1\.\n$/ + ); + $warnings = ''; +} + + +{ + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; + +#line 426 + cmp_ok( undef, "ne", "", "undef ne empty string" ); + + $TB->is_eq( $out->read, <<OUT ); +not ok - undef ne empty string +OUT + + TODO: { + local $::TODO = 'cmp_ok() gives the wrong "expected" for undef'; + + $TB->is_eq( $err->read, <<ERR ); +# Failed test 'undef ne empty string' +# at $0 line 426. +# got: undef +# expected: '' +ERR + } + + My::Test::like( + $warnings, + qr/^Use of uninitialized value.* in string ne at cmp_ok \[from $Filename line 426\] line 1\.\n\z/ + ); +} + + +# generate a $!, it changes its value by context. +-e "wibblehibble"; +my $Errno_Number = $!+0; +my $Errno_String = $!.''; +#line 425 +cmp_ok( $!, 'eq', '', ' eq with stringified errno' ); +out_ok( <<OUT, <<ERR ); +not ok - eq with stringified errno +OUT +# Failed test ' eq with stringified errno' +# at $0 line 425. +# got: '$Errno_String' +# expected: '' +ERR + +#line 436 +cmp_ok( $!, '==', -1, ' eq with numerified errno' ); +out_ok( <<OUT, <<ERR ); +not ok - eq with numerified errno +OUT +# Failed test ' eq with numerified errno' +# at $0 line 436. +# got: $Errno_Number +# expected: -1 +ERR + +#line 447 +use_ok('Hooble::mooble::yooble'); +my $more_err_re = <<ERR; +# Failed test 'use Hooble::mooble::yooble;' +# at $Filename line 447\\. +# Tried to use 'Hooble::mooble::yooble'. +# Error: Can't locate Hooble.* in \\\@INC .* +ERR +out_like( + qr/^\Qnot ok - use Hooble::mooble::yooble;\E\n\z/, + qr/^$more_err_re/ +); + +#line 460 +require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'); +$more_err_re = <<ERR; +# Failed test 'require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;' +# at $Filename line 460\\. +# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'. +# Error: Can't locate ALL.* in \\\@INC .* +ERR +out_like( + qr/^\Qnot ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;\E\n\z/, + qr/^$more_err_re/ +); + + +END { + out_like( <<OUT, <<ERR ); +OUT +# Looks like you failed $Total tests of $Total. +ERR + + exit(0); +} diff --git a/cpan/Test-Simple/t/fail.t b/cpan/Test-Simple/t/fail.t new file mode 100644 index 0000000000..ccf0c74893 --- /dev/null +++ b/cpan/Test-Simple/t/fail.t @@ -0,0 +1,56 @@ +#!perl -w + +# Simple test of what failure output looks like + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +# Normalize the output whether we're running under Test::Harness or not. +local $ENV{HARNESS_ACTIVE} = 0; + +use Test::Builder; +use Test::Builder::NoOutput; + +my $Test = Test::Builder->new; + +# Set up a builder to record some failing tests. +{ + my $tb = Test::Builder::NoOutput->create; + $tb->plan( tests => 5 ); + +#line 28 + $tb->ok( 1, 'passing' ); + $tb->ok( 2, 'passing still' ); + $tb->ok( 3, 'still passing' ); + $tb->ok( 0, 'oh no!' ); + $tb->ok( 0, 'damnit' ); + $tb->_ending; + + $Test->is_eq($tb->read('out'), <<OUT); +1..5 +ok 1 - passing +ok 2 - passing still +ok 3 - still passing +not ok 4 - oh no! +not ok 5 - damnit +OUT + + $Test->is_eq($tb->read('err'), <<ERR); +# Failed test 'oh no!' +# at $0 line 31. +# Failed test 'damnit' +# at $0 line 32. +# Looks like you failed 2 tests of 5. +ERR + + $Test->done_testing(2); +} diff --git a/cpan/Test-Simple/t/fail_one.t b/cpan/Test-Simple/t/fail_one.t new file mode 100644 index 0000000000..61d7c081ff --- /dev/null +++ b/cpan/Test-Simple/t/fail_one.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +# Normalize the output whether we're running under Test::Harness or not. +local $ENV{HARNESS_ACTIVE} = 0; + +use Test::Builder; +use Test::Builder::NoOutput; + +my $Test = Test::Builder->new; + +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->plan( tests => 1 ); + +#line 28 + $tb->ok(0); + $tb->_ending; + + $Test->is_eq($tb->read('out'), <<OUT); +1..1 +not ok 1 +OUT + + $Test->is_eq($tb->read('err'), <<ERR); +# Failed test at $0 line 28. +# Looks like you failed 1 test of 1. +ERR + + $Test->done_testing(2); +} diff --git a/cpan/Test-Simple/t/filehandles.t b/cpan/Test-Simple/t/filehandles.t new file mode 100644 index 0000000000..f7dad5d7ea --- /dev/null +++ b/cpan/Test-Simple/t/filehandles.t @@ -0,0 +1,18 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } +} + +use lib 't/lib'; +use Test::More tests => 1; +use Dev::Null; + +tie *STDOUT, "Dev::Null" or die $!; + +print "not ok 1\n"; # this should not print. +pass 'STDOUT can be mucked with'; + diff --git a/cpan/Test-Simple/t/fork.t b/cpan/Test-Simple/t/fork.t new file mode 100644 index 0000000000..55d7aec1f9 --- /dev/null +++ b/cpan/Test-Simple/t/fork.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More; +use Config; + +my $Can_Fork = $Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config{useithreads} and + $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ + ); + +if( !$Can_Fork ) { + plan skip_all => "This system cannot fork"; +} +else { + plan tests => 1; +} + +if( fork ) { # parent + pass("Only the parent should process the ending, not the child"); +} +else { + exit; # child +} + diff --git a/cpan/Test-Simple/t/harness_active.t b/cpan/Test-Simple/t/harness_active.t new file mode 100644 index 0000000000..7b027a7b40 --- /dev/null +++ b/cpan/Test-Simple/t/harness_active.t @@ -0,0 +1,88 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 4); + +# Utility testing functions. +sub ok ($;$) { + return $TB->ok(@_); +} + + +sub main::err_ok ($) { + my($expect) = @_; + my $got = $err->read; + + return $TB->is_eq( $got, $expect ); +} + + +package main; + +require Test::More; +Test::More->import(tests => 4); +Test::More->builder->no_ending(1); + +{ + local $ENV{HARNESS_ACTIVE} = 0; + +#line 62 + fail( "this fails" ); + err_ok( <<ERR ); +# Failed test 'this fails' +# at $0 line 62. +ERR + +#line 72 + is( 1, 0 ); + err_ok( <<ERR ); +# Failed test at $0 line 72. +# got: '1' +# expected: '0' +ERR +} + +{ + local $ENV{HARNESS_ACTIVE} = 1; + +#line 71 + fail( "this fails" ); + err_ok( <<ERR ); + +# Failed test 'this fails' +# at $0 line 71. +ERR + + +#line 84 + is( 1, 0 ); + err_ok( <<ERR ); + +# Failed test at $0 line 84. +# got: '1' +# expected: '0' +ERR + +} diff --git a/cpan/Test-Simple/t/import.t b/cpan/Test-Simple/t/import.t new file mode 100644 index 0000000000..68a36138bc --- /dev/null +++ b/cpan/Test-Simple/t/import.t @@ -0,0 +1,12 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + + +use Test::More tests => 2, import => [qw(!fail)]; + +can_ok(__PACKAGE__, qw(ok pass like isa_ok)); +ok( !__PACKAGE__->can('fail'), 'fail() not exported' ); diff --git a/cpan/Test-Simple/t/is_deeply_dne_bug.t b/cpan/Test-Simple/t/is_deeply_dne_bug.t new file mode 100644 index 0000000000..f4578a6460 --- /dev/null +++ b/cpan/Test-Simple/t/is_deeply_dne_bug.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl -w + +# test for rt.cpan.org 20768 +# +# There was a bug where the internal "does not exist" object could get +# confused with an overloaded object. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 2; + +{ + package Foo; + + use overload + 'eq' => \&overload_equiv, + '==' => \&overload_equiv; + + sub new { + return bless {}, shift; + } + + sub overload_equiv { + if (ref($_[0]) ne 'Foo' || ref($_[1]) ne 'Foo') { + print ref($_[0]), " ", ref($_[1]), "\n"; + die "Invalid object passed to overload_equiv\n"; + } + + return 1; # change to 0 ... makes little difference + } +} + +my $obj1 = Foo->new(); +my $obj2 = Foo->new(); + +eval { is_deeply([$obj1, $obj2], [$obj1, $obj2]); }; +is $@, ''; + diff --git a/cpan/Test-Simple/t/is_deeply_fail.t b/cpan/Test-Simple/t/is_deeply_fail.t new file mode 100644 index 0000000000..bd9b634233 --- /dev/null +++ b/cpan/Test-Simple/t/is_deeply_fail.t @@ -0,0 +1,371 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::Builder; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +Test::Builder->new->no_header(1); +Test::Builder->new->no_ending(1); +local $ENV{HARNESS_ACTIVE} = 0; + + +# Can't use Test.pm, that's a 5.005 thing. +package main; + + +my $TB = Test::Builder->create; +$TB->plan(tests => 73); + +# Utility testing functions. +sub ok ($;$) { + return $TB->ok(@_); +} + +sub is ($$;$) { + my($this, $that, $name) = @_; + + my $ok = $TB->is_eq($$this, $that, $name); + + $$this = ''; + + return $ok; +} + +sub like ($$;$) { + my($this, $regex, $name) = @_; + $regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s; + + my $ok = $TB->like($$this, $regex, $name); + + $$this = ''; + + return $ok; +} + + +require Test::More; +Test::More->import(tests => 11, import => ['is_deeply']); + +my $Filename = quotemeta $0; + +#line 68 +ok !is_deeply('foo', 'bar', 'plain strings'); +is( $out, "not ok 1 - plain strings\n", 'plain strings' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'plain strings' +# at $0 line 68. +# got: 'foo' +# expected: 'bar' +ERR + + +#line 78 +ok !is_deeply({}, [], 'different types'); +is( $out, "not ok 2 - different types\n", 'different types' ); +like( $err, <<ERR, ' right diagnostic' ); +# Failed test 'different types' +# at $Filename line 78. +# Structures begin differing at: +# \\\$got = HASH\\(0x[0-9a-f]+\\) +# \\\$expected = ARRAY\\(0x[0-9a-f]+\\) +ERR + +#line 88 +ok !is_deeply({ this => 42 }, { this => 43 }, 'hashes with different values'); +is( $out, "not ok 3 - hashes with different values\n", + 'hashes with different values' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'hashes with different values' +# at $0 line 88. +# Structures begin differing at: +# \$got->{this} = '42' +# \$expected->{this} = '43' +ERR + +#line 99 +ok !is_deeply({ that => 42 }, { this => 42 }, 'hashes with different keys'); +is( $out, "not ok 4 - hashes with different keys\n", + 'hashes with different keys' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'hashes with different keys' +# at $0 line 99. +# Structures begin differing at: +# \$got->{this} = Does not exist +# \$expected->{this} = '42' +ERR + +#line 110 +ok !is_deeply([1..9], [1..10], 'arrays of different length'); +is( $out, "not ok 5 - arrays of different length\n", + 'arrays of different length' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'arrays of different length' +# at $0 line 110. +# Structures begin differing at: +# \$got->[9] = Does not exist +# \$expected->[9] = '10' +ERR + +#line 121 +ok !is_deeply([undef, undef], [undef], 'arrays of undefs' ); +is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'arrays of undefs' +# at $0 line 121. +# Structures begin differing at: +# \$got->[1] = undef +# \$expected->[1] = Does not exist +ERR + +#line 131 +ok !is_deeply({ foo => undef }, {}, 'hashes of undefs' ); +is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'hashes of undefs' +# at $0 line 131. +# Structures begin differing at: +# \$got->{foo} = undef +# \$expected->{foo} = Does not exist +ERR + +#line 141 +ok !is_deeply(\42, \23, 'scalar refs'); +is( $out, "not ok 8 - scalar refs\n", 'scalar refs' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'scalar refs' +# at $0 line 141. +# Structures begin differing at: +# \${ \$got} = '42' +# \${\$expected} = '23' +ERR + +#line 151 +ok !is_deeply([], \23, 'mixed scalar and array refs'); +is( $out, "not ok 9 - mixed scalar and array refs\n", + 'mixed scalar and array refs' ); +like( $err, <<ERR, ' right diagnostic' ); +# Failed test 'mixed scalar and array refs' +# at $Filename line 151. +# Structures begin differing at: +# \\\$got = ARRAY\\(0x[0-9a-f]+\\) +# \\\$expected = SCALAR\\(0x[0-9a-f]+\\) +ERR + + +my($a1, $a2, $a3); +$a1 = \$a2; $a2 = \$a3; +$a3 = 42; + +my($b1, $b2, $b3); +$b1 = \$b2; $b2 = \$b3; +$b3 = 23; + +#line 173 +ok !is_deeply($a1, $b1, 'deep scalar refs'); +is( $out, "not ok 10 - deep scalar refs\n", 'deep scalar refs' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'deep scalar refs' +# at $0 line 173. +# Structures begin differing at: +# \${\${ \$got}} = '42' +# \${\${\$expected}} = '23' +ERR + +# I don't know how to properly display this structure. +# $a2 = { foo => \$a3 }; +# $b2 = { foo => \$b3 }; +# is_deeply([$a1], [$b1], 'deep mixed scalar refs'); + +my $foo = { + this => [1..10], + that => { up => "down", left => "right" }, + }; + +my $bar = { + this => [1..10], + that => { up => "down", left => "right", foo => 42 }, + }; + +#line 198 +ok !is_deeply( $foo, $bar, 'deep structures' ); +ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); +is( $out, "not ok 11 - deep structures\n", 'deep structures' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test 'deep structures' +# at $0 line 198. +# Structures begin differing at: +# \$got->{that}{foo} = Does not exist +# \$expected->{that}{foo} = '42' +ERR + + +#line 221 +my @tests = ([], + [qw(42)], + [qw(42 23), qw(42 23)] + ); + +foreach my $test (@tests) { + my $num_args = @$test; + + my $warning; + local $SIG{__WARN__} = sub { $warning .= join '', @_; }; + ok !is_deeply(@$test); + + like \$warning, + "/^is_deeply\\(\\) takes two or three args, you gave $num_args\.\n/"; +} + + +#line 240 +# [rt.cpan.org 6837] +ok !is_deeply([{Foo => undef}],[{Foo => ""}]), 'undef != ""'; +ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); + + +#line 258 +# [rt.cpan.org 7031] +my $a = []; +ok !is_deeply($a, $a.''), "don't compare refs like strings"; +ok !is_deeply([$a], [$a.'']), " even deep inside"; + + +#line 265 +# [rt.cpan.org 7030] +ok !is_deeply( {}, {key => []} ), '[] could match non-existent values'; +ok !is_deeply( [], [[]] ); + + +#line 273 +$$err = $$out = ''; +ok !is_deeply( [\'a', 'b'], [\'a', 'c'] ); +is( $out, "not ok 20\n", 'scalar refs in an array' ); +is( $err, <<ERR, ' right diagnostic' ); +# Failed test at $0 line 274. +# Structures begin differing at: +# \$got->[1] = 'b' +# \$expected->[1] = 'c' +ERR + + +#line 285 +my $ref = \23; +ok !is_deeply( 23, $ref ); +is( $out, "not ok 21\n", 'scalar vs ref' ); +is( $err, <<ERR, ' right diagnostic'); +# Failed test at $0 line 286. +# Structures begin differing at: +# \$got = '23' +# \$expected = $ref +ERR + +#line 296 +ok !is_deeply( $ref, 23 ); +is( $out, "not ok 22\n", 'ref vs scalar' ); +is( $err, <<ERR, ' right diagnostic'); +# Failed test at $0 line 296. +# Structures begin differing at: +# \$got = $ref +# \$expected = '23' +ERR + +#line 306 +ok !is_deeply( undef, [] ); +is( $out, "not ok 23\n", 'is_deeply and undef [RT 9441]' ); +like( $err, <<ERR, ' right diagnostic' ); +# Failed test at $Filename line 306\\. +# Structures begin differing at: +# \\\$got = undef +# \\\$expected = ARRAY\\(0x[0-9a-f]+\\) +ERR + + +# rt.cpan.org 8865 +{ + my $array = []; + my $hash = {}; + +#line 321 + ok !is_deeply( $array, $hash ); + is( $out, "not ok 24\n", 'is_deeply and different reference types' ); + is( $err, <<ERR, ' right diagnostic' ); +# Failed test at $0 line 321. +# Structures begin differing at: +# \$got = $array +# \$expected = $hash +ERR + +#line 332 + ok !is_deeply( [$array], [$hash] ); + is( $out, "not ok 25\n", 'nested different ref types' ); + is( $err, <<ERR, ' right diagnostic' ); +# Failed test at $0 line 332. +# Structures begin differing at: +# \$got->[0] = $array +# \$expected->[0] = $hash +ERR + + + # Overloaded object tests + { + my $foo = bless [], "Foo"; + my $bar = bless {}, "Bar"; + + { + package Bar; + "overload"->import(q[""] => sub { "wibble" }); + } + +#line 353 + ok !is_deeply( [$foo], [$bar] ); + is( $out, "not ok 26\n", 'string overloaded refs respected in diag' ); + is( $err, <<ERR, ' right diagnostic' ); +# Failed test at $0 line 353. +# Structures begin differing at: +# \$got->[0] = $foo +# \$expected->[0] = 'wibble' +ERR + + } +} + + +# rt.cpan.org 14746 +{ +# line 349 + ok !is_deeply( sub {"foo"}, sub {"bar"} ), 'function refs'; + is( $out, "not ok 27\n" ); + like( $err, <<ERR, ' right diagnostic' ); +# Failed test at $Filename line 349. +# Structures begin differing at: +# \\\$got = CODE\\(0x[0-9a-f]+\\) +# \\\$expected = CODE\\(0x[0-9a-f]+\\) +ERR + + + use Symbol; + my $glob1 = gensym; + my $glob2 = gensym; + +#line 357 + ok !is_deeply( $glob1, $glob2 ), 'typeglobs'; + is( $out, "not ok 28\n" ); + like( $err, <<ERR, ' right diagnostic' ); +# Failed test at $Filename line 357. +# Structures begin differing at: +# \\\$got = GLOB\\(0x[0-9a-f]+\\) +# \\\$expected = GLOB\\(0x[0-9a-f]+\\) +ERR + +} diff --git a/cpan/Test-Simple/t/is_deeply_with_threads.t b/cpan/Test-Simple/t/is_deeply_with_threads.t new file mode 100644 index 0000000000..9908ef6608 --- /dev/null +++ b/cpan/Test-Simple/t/is_deeply_with_threads.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl -w + +# Test to see if is_deeply() plays well with threads. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Config; + +BEGIN { + unless ( $] >= 5.008001 && $Config{'useithreads'} && + eval { require threads; 'threads'->import; 1; }) + { + print "1..0 # Skip no working threads\n"; + exit 0; + } + + unless ( $ENV{AUTHOR_TESTING} ) { + print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; + exit 0; + } +} +use Test::More; + +my $Num_Threads = 5; + +plan tests => $Num_Threads * 100 + 6; + + +sub do_one_thread { + my $kid = shift; + my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', + 'hello', 's', 'thisisalongname', '1', '2', '3', + 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); + my @list2 = @list; + print "# kid $kid before is_deeply\n"; + + for my $j (1..100) { + is_deeply(\@list, \@list2); + } + print "# kid $kid exit\n"; + return 42; +} + +my @kids = (); +for my $i (1..$Num_Threads) { + my $t = threads->new(\&do_one_thread, $i); + print "# parent $$: continue\n"; + push(@kids, $t); +} +for my $t (@kids) { + print "# parent $$: waiting for join\n"; + my $rc = $t->join(); + cmp_ok( $rc, '==', 42, "threads exit status is $rc" ); +} + +pass("End of test"); diff --git a/cpan/Test-Simple/t/lib/Dev/Null.pm b/cpan/Test-Simple/t/lib/Dev/Null.pm new file mode 100644 index 0000000000..24ec07ab57 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Dev/Null.pm @@ -0,0 +1,8 @@ +package Dev::Null; + +use strict; + +sub TIEHANDLE { bless {}, shift } +sub PRINT { 1 } + +1; diff --git a/cpan/Test-Simple/t/lib/Dummy.pm b/cpan/Test-Simple/t/lib/Dummy.pm new file mode 100644 index 0000000000..cdff79d540 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Dummy.pm @@ -0,0 +1,6 @@ +package Dummy; + +use strict; +our $VERSION = '0.01'; + +1; diff --git a/cpan/Test-Simple/t/lib/MyOverload.pm b/cpan/Test-Simple/t/lib/MyOverload.pm new file mode 100644 index 0000000000..65f5ea5a7d --- /dev/null +++ b/cpan/Test-Simple/t/lib/MyOverload.pm @@ -0,0 +1,30 @@ +package Overloaded; ##no critic (Modules::RequireFilenameMatchesPackage) + +use strict; + +sub new { + my $class = shift; + bless { string => shift, num => shift }, $class; +} + +package Overloaded::Compare; + +use strict; +our @ISA = qw(Overloaded); + +# Sometimes objects have only comparison ops overloaded and nothing else. +# For example, DateTime objects. +use overload + q{eq} => sub { $_[0]->{string} eq $_[1] }, + q{==} => sub { $_[0]->{num} == $_[1] }; + +package Overloaded::Ify; + +use strict; +our @ISA = qw(Overloaded); + +use overload + q{""} => sub { $_[0]->{string} }, + q{0+} => sub { $_[0]->{num} }; + +1; diff --git a/cpan/Test-Simple/t/lib/NoExporter.pm b/cpan/Test-Simple/t/lib/NoExporter.pm new file mode 100644 index 0000000000..6273e32d74 --- /dev/null +++ b/cpan/Test-Simple/t/lib/NoExporter.pm @@ -0,0 +1,12 @@ +package NoExporter; + +use strict; +our $VERSION = 1.02; + +sub import { + shift; + die "NoExporter exports nothing. You asked for: @_" if @_; +} + +1; + diff --git a/cpan/Test-Simple/t/lib/SigDie.pm b/cpan/Test-Simple/t/lib/SigDie.pm new file mode 100644 index 0000000000..0774728d4e --- /dev/null +++ b/cpan/Test-Simple/t/lib/SigDie.pm @@ -0,0 +1,8 @@ +package SigDie; + +use strict; + +our $DIE; +$SIG{__DIE__} = sub { $DIE = $@ }; + +1; diff --git a/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm new file mode 100644 index 0000000000..d83db9f178 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm @@ -0,0 +1,122 @@ +package Test::Builder::NoOutput; + +use strict; +use warnings; + +use base qw(Test::Builder); + + +=head1 NAME + +Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing + +=head1 SYNOPSIS + + use Test::Builder::NoOutput; + + my $tb = Test::Builder::NoOutput->new; + + ...test as normal... + + my $output = $tb->read; + +=head1 DESCRIPTION + +This is a subclass of Test::Builder which traps all its output. +It is mostly useful for testing Test::Builder. + +=head3 read + + my $all_output = $tb->read; + my $output = $tb->read($stream); + +Returns all the output (including failure and todo output) collected +so far. It is destructive, each call to read clears the output +buffer. + +If $stream is given it will return just the output from that stream. +$stream's are... + + out output() + err failure_output() + todo todo_output() + all all outputs + +Defaults to 'all'. + +=cut + +my $Test = __PACKAGE__->new; + +sub create { + my $class = shift; + my $self = $class->SUPER::create(@_); + + my %outputs = ( + all => '', + out => '', + err => '', + todo => '', + ); + $self->{_outputs} = \%outputs; + + tie *OUT, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{out}; + tie *ERR, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{err}; + tie *TODO, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{todo}; + + $self->output(*OUT); + $self->failure_output(*ERR); + $self->todo_output(*TODO); + + return $self; +} + +sub read { + my $self = shift; + my $stream = @_ ? shift : 'all'; + + my $out = $self->{_outputs}{$stream}; + + $self->{_outputs}{$stream} = ''; + + # Clear all the streams if 'all' is read. + if( $stream eq 'all' ) { + my @keys = keys %{$self->{_outputs}}; + $self->{_outputs}{$_} = '' for @keys; + } + + return $out; +} + + +package Test::Builder::NoOutput::Tee; + +# A cheap implementation of IO::Tee. + +sub TIEHANDLE { + my($class, @refs) = @_; + + my @fhs; + for my $ref (@refs) { + my $fh = Test::Builder->_new_fh($ref); + push @fhs, $fh; + } + + my $self = [@fhs]; + return bless $self, $class; +} + +sub PRINT { + my $self = shift; + + print $_ @_ for @$self; +} + +sub PRINTF { + my $self = shift; + my $format = shift; + + printf $_ @_ for @$self; +} + +1; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/Catch.pm b/cpan/Test-Simple/t/lib/Test/Simple/Catch.pm new file mode 100644 index 0000000000..9a2efb192d --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/Catch.pm @@ -0,0 +1,20 @@ +# For testing Test::Simple; +package Test::Simple::Catch; + +use strict; + +use Symbol; +use TieOut; +my( $out_fh, $err_fh ) = ( gensym, gensym ); +my $out = tie *$out_fh, 'TieOut'; +my $err = tie *$err_fh, 'TieOut'; + +use Test::Builder; +my $t = Test::Builder->new; +$t->output($out_fh); +$t->failure_output($err_fh); +$t->todo_output($err_fh); + +sub caught { return( $out, $err ) } + +1; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death.plx new file mode 100644 index 0000000000..e682ec08a2 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death.plx @@ -0,0 +1,16 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +require Dev::Null; + +Test::Simple->import(tests => 5); +tie *STDERR, 'Dev::Null'; + +ok(1); +ok(1); +ok(1); +$! = 0; +die "This is a test"; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx new file mode 100644 index 0000000000..269bffa802 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx @@ -0,0 +1,22 @@ +require Test::Simple; +use Carp; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + +ok(1); +ok(1); +ok(1); +eval { + die "Foo"; +}; +ok(1); +eval "die 'Bar'"; +ok(1); + +eval { + croak "Moo"; +}; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_with_handler.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_with_handler.plx new file mode 100644 index 0000000000..7dabb31d60 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_with_handler.plx @@ -0,0 +1,20 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 2); + +# Test we still get the right exit code despite having a die +# handler. +$SIG{__DIE__} = sub {}; + +require Dev::Null; +tie *STDERR, 'Dev::Null'; + +ok(1); +ok(1); + +$! = 0; +die "This is a test"; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/exit.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/exit.plx new file mode 100644 index 0000000000..7f8ff73f75 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/exit.plx @@ -0,0 +1,3 @@ +require Test::Builder; + +exit 1; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/extras.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/extras.plx new file mode 100644 index 0000000000..c9c89520aa --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/extras.plx @@ -0,0 +1,16 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + + +ok(1); +ok(1); +ok(1); +ok(1); +ok(0); +ok(1); +ok(0); diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/five_fail.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/five_fail.plx new file mode 100644 index 0000000000..c058e1f8f0 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/five_fail.plx @@ -0,0 +1,13 @@ +require Test::Simple; + +use lib 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + +ok(0); +ok(0); +ok(''); +ok(0); +ok(0); diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/last_minute_death.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/last_minute_death.plx new file mode 100644 index 0000000000..e3d01beeb7 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/last_minute_death.plx @@ -0,0 +1,19 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + +require Dev::Null; +tie *STDERR, 'Dev::Null'; + +ok(1); +ok(1); +ok(1); +ok(1); +ok(1); + +$! = 0; +die "This is a test"; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/one_fail.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/one_fail.plx new file mode 100644 index 0000000000..99c720250d --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/one_fail.plx @@ -0,0 +1,14 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + + +ok(1); +ok(2); +ok(0); +ok(1); +ok(2); diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/pre_plan_death.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/pre_plan_death.plx new file mode 100644 index 0000000000..f72d3b65e5 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/pre_plan_death.plx @@ -0,0 +1,17 @@ +# ID 20020716.013, the exit code would become 0 if the test died +# before a plan. + +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +close STDERR; +die "Knife?"; + +Test::Simple->import(tests => 3); + +ok(1); +ok(1); +ok(1); diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/require.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/require.plx new file mode 100644 index 0000000000..1a06690d9d --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/require.plx @@ -0,0 +1 @@ +require Test::Simple; diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/success.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/success.plx new file mode 100644 index 0000000000..585d6c3d79 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/success.plx @@ -0,0 +1,13 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + +ok(1); +ok(5, 'yep'); +ok(3, 'beer'); +ok("wibble", "wibble"); +ok(1); diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few.plx new file mode 100644 index 0000000000..bbc630ddce --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few.plx @@ -0,0 +1,11 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + + +ok(1); +ok(1); diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx new file mode 100644 index 0000000000..9ca4517b66 --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx @@ -0,0 +1,12 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + + +ok(0); +ok(1); +ok(0); diff --git a/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/two_fail.plx b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/two_fail.plx new file mode 100644 index 0000000000..e3d92296af --- /dev/null +++ b/cpan/Test-Simple/t/lib/Test/Simple/sample_tests/two_fail.plx @@ -0,0 +1,14 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + + +ok(0); +ok(1); +ok(1); +ok(0); +ok(1); diff --git a/cpan/Test-Simple/t/lib/TieOut.pm b/cpan/Test-Simple/t/lib/TieOut.pm new file mode 100644 index 0000000000..a08a9116ba --- /dev/null +++ b/cpan/Test-Simple/t/lib/TieOut.pm @@ -0,0 +1,30 @@ +package TieOut; + +use strict; + +sub TIEHANDLE { + my $scalar = ''; + bless( \$scalar, $_[0] ); +} + +sub PRINT { + my $self = shift; + $$self .= join( '', @_ ); +} + +sub PRINTF { + my $self = shift; + my $fmt = shift; + $$self .= sprintf $fmt, @_; +} + +sub FILENO { } + +sub read { + my $self = shift; + my $data = $$self; + $$self = ''; + return $data; +} + +1; diff --git a/cpan/Test-Simple/t/missing.t b/cpan/Test-Simple/t/missing.t new file mode 100644 index 0000000000..3996b6de4b --- /dev/null +++ b/cpan/Test-Simple/t/missing.t @@ -0,0 +1,56 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 2); + +sub is { $TB->is_eq(@_) } + + +package main; + +require Test::Simple; + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 5); + +#line 30 +ok(1, 'Foo'); +ok(0, 'Bar'); +ok(1, '1 2 3'); + +END { + My::Test::is($$out, <<OUT); +1..5 +ok 1 - Foo +not ok 2 - Bar +ok 3 - 1 2 3 +OUT + + My::Test::is($$err, <<ERR); +# Failed test 'Bar' +# at $0 line 31. +# You named your test '1 2 3'. You shouldn't use numbers for your test names. +# Very confusing. +# Looks like you planned 5 tests but ran 3. +# Looks like you failed 1 test of 3 run. +ERR + + exit 0; +} diff --git a/cpan/Test-Simple/t/new_ok.t b/cpan/Test-Simple/t/new_ok.t new file mode 100644 index 0000000000..d53f535d1c --- /dev/null +++ b/cpan/Test-Simple/t/new_ok.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More tests => 13; + +{ + package Bar; + + sub new { + my $class = shift; + return bless {@_}, $class; + } + + + package Foo; + our @ISA = qw(Bar); +} + +{ + my $obj = new_ok("Foo"); + is_deeply $obj, {}; + isa_ok $obj, "Foo"; + + $obj = new_ok("Bar"); + is_deeply $obj, {}; + isa_ok $obj, "Bar"; + + $obj = new_ok("Foo", [this => 42]); + is_deeply $obj, { this => 42 }; + isa_ok $obj, "Foo"; + + $obj = new_ok("Foo", [], "Foo"); + is_deeply $obj, {}; + isa_ok $obj, "Foo"; +} + +# And what if we give it nothing? +eval { + new_ok(); +}; +is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2; diff --git a/cpan/Test-Simple/t/no_plan.t b/cpan/Test-Simple/t/no_plan.t new file mode 100644 index 0000000000..5f392e40e1 --- /dev/null +++ b/cpan/Test-Simple/t/no_plan.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More tests => 7; + +my $tb = Test::Builder->create; + +#line 20 +ok !eval { $tb->plan(tests => undef) }; +is($@, "Got an undefined number of tests at $0 line 20.\n"); + +#line 24 +ok !eval { $tb->plan(tests => 0) }; +is($@, "You said to run 0 tests at $0 line 24.\n"); + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= join '', @_ }; + +#line 31 + ok $tb->plan(no_plan => 1); + is( $warning, "no_plan takes no arguments at $0 line 31.\n" ); + is $tb->has_plan, 'no_plan'; +} diff --git a/cpan/Test-Simple/t/no_tests.t b/cpan/Test-Simple/t/no_tests.t new file mode 100644 index 0000000000..eafa38cacc --- /dev/null +++ b/cpan/Test-Simple/t/no_tests.t @@ -0,0 +1,44 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 3); + + +package main; + +require Test::Simple; + +chdir 't'; +push @INC, '../t/lib/'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 1); + +END { + $TB->is_eq($out->read, <<OUT); +1..1 +OUT + + $TB->is_eq($err->read, <<ERR); +# No tests run! +ERR + + $TB->is_eq($?, 255, "exit code"); + + exit grep { !$_ } $TB->summary; +} diff --git a/cpan/Test-Simple/t/note.t b/cpan/Test-Simple/t/note.t new file mode 100644 index 0000000000..fb98fb4029 --- /dev/null +++ b/cpan/Test-Simple/t/note.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::Builder::NoOutput; + +use Test::More tests => 2; + +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->note("foo"); + + $tb->reset_outputs; + + is $tb->read('out'), "# foo\n"; + is $tb->read('err'), ''; +} + diff --git a/cpan/Test-Simple/t/overload.t b/cpan/Test-Simple/t/overload.t new file mode 100644 index 0000000000..a86103746b --- /dev/null +++ b/cpan/Test-Simple/t/overload.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 19; + + +package Overloaded; + +use overload + q{eq} => sub { $_[0]->{string} eq $_[1] }, + q{==} => sub { $_[0]->{num} == $_[1] }, + q{""} => sub { $_[0]->{stringify}++; $_[0]->{string} }, + q{0+} => sub { $_[0]->{numify}++; $_[0]->{num} } +; + +sub new { + my $class = shift; + bless { + string => shift, + num => shift, + stringify => 0, + numify => 0, + }, $class; +} + + +package main; + +local $SIG{__DIE__} = sub { + my($call_file, $call_line) = (caller)[1,2]; + fail("SIGDIE accidentally called"); + diag("From $call_file at $call_line"); +}; + +my $obj = Overloaded->new('foo', 42); +isa_ok $obj, 'Overloaded'; + +cmp_ok $obj, 'eq', 'foo', 'cmp_ok() eq'; +is $obj->{stringify}, 0, ' does not stringify'; +is $obj, 'foo', 'is() with string overloading'; +cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading'; +is $obj->{numify}, 0, ' does not numify'; + +is_deeply [$obj], ['foo'], 'is_deeply with string overloading'; +ok eq_array([$obj], ['foo']), 'eq_array ...'; +ok eq_hash({foo => $obj}, {foo => 'foo'}), 'eq_hash ...'; + +# rt.cpan.org 13506 +is_deeply $obj, 'foo', 'is_deeply with string overloading at the top'; + +Test::More->builder->is_num($obj, 42); +Test::More->builder->is_eq ($obj, "foo"); + + +{ + # rt.cpan.org 14675 + package TestPackage; + use overload q{""} => sub { ::fail("This should not be called") }; + + package Foo; + ::is_deeply(['TestPackage'], ['TestPackage']); + ::is_deeply({'TestPackage' => 'TestPackage'}, + {'TestPackage' => 'TestPackage'}); + ::is_deeply('TestPackage', 'TestPackage'); +} + + +# Make sure 0 isn't a special case. [rt.cpan.org 41109] +{ + my $obj = Overloaded->new('0', 42); + isa_ok $obj, 'Overloaded'; + + cmp_ok $obj, 'eq', '0', 'cmp_ok() eq'; + is $obj->{stringify}, 0, ' does not stringify'; + is $obj, '0', 'is() with string overloading'; +} diff --git a/cpan/Test-Simple/t/overload_threads.t b/cpan/Test-Simple/t/overload_threads.t new file mode 100644 index 0000000000..379e347bae --- /dev/null +++ b/cpan/Test-Simple/t/overload_threads.t @@ -0,0 +1,60 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} +chdir 't'; + +BEGIN { + # There was a bug with overloaded objects and threads. + # See rt.cpan.org 4218 + eval { require threads; 'threads'->import; 1; }; +} + +use Test::More tests => 5; + + +package Overloaded; + +use overload + q{""} => sub { $_[0]->{string} }; + +sub new { + my $class = shift; + bless { string => shift }, $class; +} + + +package main; + +my $warnings = ''; +local $SIG{__WARN__} = sub { $warnings = join '', @_ }; + +# overloaded object as name +my $obj = Overloaded->new('foo'); +ok( 1, $obj ); + +# overloaded object which returns undef as name +my $undef = Overloaded->new(undef); +pass( $undef ); + +is( $warnings, '' ); + + +TODO: { + my $obj = Overloaded->new('not really todo, testing overloaded reason'); + local $TODO = $obj; + fail("Just checking todo as an overloaded value"); +} + + +SKIP: { + my $obj = Overloaded->new('not really skipped, testing overloaded reason'); + skip $obj, 1; +} diff --git a/cpan/Test-Simple/t/plan.t b/cpan/Test-Simple/t/plan.t new file mode 100644 index 0000000000..0d3ce89edb --- /dev/null +++ b/cpan/Test-Simple/t/plan.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More; + +plan tests => 4; +eval { plan tests => 4 }; +is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ - 1), + 'disallow double plan' ); +eval { plan 'no_plan' }; +is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ -1), + 'disallow changing plan' ); + +pass('Just testing plan()'); +pass('Testing it some more'); diff --git a/cpan/Test-Simple/t/plan_bad.t b/cpan/Test-Simple/t/plan_bad.t new file mode 100644 index 0000000000..179356dbc1 --- /dev/null +++ b/cpan/Test-Simple/t/plan_bad.t @@ -0,0 +1,37 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + + +use Test::More tests => 12; +use Test::Builder; +my $tb = Test::Builder->create; +$tb->level(0); + +ok !eval { $tb->plan( tests => 'no_plan' ); }; +is $@, sprintf "Number of tests must be a positive integer. You gave it 'no_plan' at %s line %d.\n", $0, __LINE__ - 1; + +my $foo = []; +my @foo = ($foo, 2, 3); +ok !eval { $tb->plan( tests => @foo ) }; +is $@, sprintf "Number of tests must be a positive integer. You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1; + +ok !eval { $tb->plan( tests => 9.99 ) }; +is $@, sprintf "Number of tests must be a positive integer. You gave it '9.99' at %s line %d.\n", $0, __LINE__ - 1; + +#line 25 +ok !eval { $tb->plan( tests => -1 ) }; +is $@, "Number of tests must be a positive integer. You gave it '-1' at $0 line 25.\n"; + +#line 29 +ok !eval { $tb->plan( tests => '' ) }; +is $@, "You said to run 0 tests at $0 line 29.\n"; + +#line 33 +ok !eval { $tb->plan( 'wibble' ) }; +is $@, "plan() doesn't understand wibble at $0 line 33.\n"; diff --git a/cpan/Test-Simple/t/plan_is_noplan.t b/cpan/Test-Simple/t/plan_is_noplan.t new file mode 100644 index 0000000000..1e696042ef --- /dev/null +++ b/cpan/Test-Simple/t/plan_is_noplan.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::More tests => 1; + +use Test::Builder::NoOutput; + +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->plan('no_plan'); + + $tb->ok(1, 'foo'); + $tb->_ending; + + is($tb->read, <<OUT); +ok 1 - foo +1..1 +OUT +} + diff --git a/cpan/Test-Simple/t/plan_no_plan.t b/cpan/Test-Simple/t/plan_no_plan.t new file mode 100644 index 0000000000..3111592e97 --- /dev/null +++ b/cpan/Test-Simple/t/plan_no_plan.t @@ -0,0 +1,40 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More; + +BEGIN { + if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) { + plan skip_all => "Won't work with t/TEST"; + } +} + +plan 'no_plan'; + +pass('Just testing'); +ok(1, 'Testing again'); + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = join "", @_ }; + SKIP: { + skip 'Just testing skip with no_plan'; + fail("So very failed"); + } + is( $warning, '', 'skip with no "how_many" ok with no_plan' ); + + + $warning = ''; + TODO: { + todo_skip "Just testing todo_skip"; + + fail("Just testing todo"); + die "todo_skip should prevent this"; + pass("Again"); + } + is( $warning, '', 'skip with no "how_many" ok with no_plan' ); +} diff --git a/cpan/Test-Simple/t/plan_shouldnt_import.t b/cpan/Test-Simple/t/plan_shouldnt_import.t new file mode 100644 index 0000000000..b6eb064244 --- /dev/null +++ b/cpan/Test-Simple/t/plan_shouldnt_import.t @@ -0,0 +1,16 @@ +#!/usr/bin/perl -w + +# plan() used to export functions by mistake [rt.cpan.org 8385] + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + + +use Test::More (); +Test::More::plan(tests => 1); + +Test::More::ok( !__PACKAGE__->can('ok'), 'plan should not export' ); diff --git a/cpan/Test-Simple/t/plan_skip_all.t b/cpan/Test-Simple/t/plan_skip_all.t new file mode 100644 index 0000000000..528df5f50d --- /dev/null +++ b/cpan/Test-Simple/t/plan_skip_all.t @@ -0,0 +1,12 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More; + +plan skip_all => 'Just testing plan & skip_all'; + +fail('We should never get here'); diff --git a/cpan/Test-Simple/t/require_ok.t b/cpan/Test-Simple/t/require_ok.t new file mode 100644 index 0000000000..463a007599 --- /dev/null +++ b/cpan/Test-Simple/t/require_ok.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 8; + +# Symbol and Class::Struct are both non-XS core modules back to 5.004. +# So they'll always be there. +require_ok("Symbol"); +ok( $INC{'Symbol.pm'}, "require_ok MODULE" ); + +require_ok("Class/Struct.pm"); +ok( $INC{'Class/Struct.pm'}, "require_ok FILE" ); + +# Its more trouble than its worth to try to create these filepaths to test +# through require_ok() so we cheat and use the internal logic. +ok !Test::More::_is_module_name('foo:bar'); +ok !Test::More::_is_module_name('foo/bar.thing'); +ok !Test::More::_is_module_name('Foo::Bar::'); +ok Test::More::_is_module_name('V'); diff --git a/cpan/Test-Simple/t/simple.t b/cpan/Test-Simple/t/simple.t new file mode 100644 index 0000000000..7297e9d6dd --- /dev/null +++ b/cpan/Test-Simple/t/simple.t @@ -0,0 +1,17 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; + +BEGIN { $| = 1; $^W = 1; } + +use Test::Simple tests => 3; + +ok(1, 'compile'); + +ok(1); +ok(1, 'foo'); diff --git a/cpan/Test-Simple/t/skip.t b/cpan/Test-Simple/t/skip.t new file mode 100644 index 0000000000..f2ea9fbf20 --- /dev/null +++ b/cpan/Test-Simple/t/skip.t @@ -0,0 +1,98 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 17; + +# If we skip with the same name, Test::Harness will report it back and +# we won't get lots of false bug reports. +my $Why = "Just testing the skip interface."; + +SKIP: { + skip $Why, 2 + unless Pigs->can('fly'); + + my $pig = Pigs->new; + $pig->takeoff; + + ok( $pig->altitude > 0, 'Pig is airborne' ); + ok( $pig->airspeed > 0, ' and moving' ); +} + + +SKIP: { + skip "We're not skipping", 2 if 0; + + pass("Inside skip block"); + pass("Another inside"); +} + + +SKIP: { + skip "Again, not skipping", 2 if 0; + + my($pack, $file, $line) = caller; + is( $pack || '', '', 'calling package not interfered with' ); + is( $file || '', '', ' or file' ); + is( $line || '', '', ' or line' ); +} + + +SKIP: { + skip $Why, 2 if 1; + + die "A horrible death"; + fail("Deliberate failure"); + fail("And again"); +} + + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = join "", @_ }; + SKIP: { + # perl gets the line number a little wrong on the first + # statement inside a block. + 1 == 1; +#line 56 + skip $Why; + fail("So very failed"); + } + is( $warning, "skip() needs to know \$how_many tests are in the ". + "block at $0 line 56\n", + 'skip without $how_many warning' ); +} + + +SKIP: { + skip "Not skipping here.", 4 if 0; + + pass("This is supposed to run"); + + # Testing out nested skips. + SKIP: { + skip $Why, 2; + fail("AHHH!"); + fail("You're a failure"); + } + + pass("This is supposed to run, too"); +} + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= join "", @_ }; + + SKIP: { + skip 1, "This is backwards" if 1; + + pass "This does not run"; + } + + like $warning, qr/^skip\(\) was passed a non-numeric number of tests/; +} diff --git a/cpan/Test-Simple/t/skipall.t b/cpan/Test-Simple/t/skipall.t new file mode 100644 index 0000000000..5491be126e --- /dev/null +++ b/cpan/Test-Simple/t/skipall.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::More; + +my $Test = Test::Builder->create; +$Test->plan(tests => 2); + +my $out = ''; +my $err = ''; +{ + my $tb = Test::More->builder; + $tb->output(\$out); + $tb->failure_output(\$err); + + plan 'skip_all'; +} + +END { + $Test->is_eq($out, "1..0 # SKIP\n"); + $Test->is_eq($err, ""); +} diff --git a/cpan/Test-Simple/t/tbm_doesnt_set_exported_to.t b/cpan/Test-Simple/t/tbm_doesnt_set_exported_to.t new file mode 100644 index 0000000000..8bdd17753b --- /dev/null +++ b/cpan/Test-Simple/t/tbm_doesnt_set_exported_to.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; +use warnings; + +# Can't use Test::More, that would set exported_to() +use Test::Builder; +use Test::Builder::Module; + +my $TB = Test::Builder->create; +$TB->plan( tests => 1 ); +$TB->level(0); + +$TB->is_eq( Test::Builder::Module->builder->exported_to, + undef, + 'using Test::Builder::Module does not set exported_to()' +); diff --git a/cpan/Test-Simple/t/thread_taint.t b/cpan/Test-Simple/t/thread_taint.t new file mode 100644 index 0000000000..ef7b89daef --- /dev/null +++ b/cpan/Test-Simple/t/thread_taint.t @@ -0,0 +1,5 @@ +#!/usr/bin/perl -w + +use Test::More tests => 1; + +ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' ); diff --git a/cpan/Test-Simple/t/threads.t b/cpan/Test-Simple/t/threads.t new file mode 100644 index 0000000000..42ba8c269c --- /dev/null +++ b/cpan/Test-Simple/t/threads.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Config; +BEGIN { + unless ( $] >= 5.008001 && $Config{'useithreads'} && + eval { require threads; 'threads'->import; 1; }) + { + print "1..0 # Skip: no working threads\n"; + exit 0; + } +} + +use strict; +use Test::Builder; + +my $Test = Test::Builder->new; +$Test->exported_to('main'); +$Test->plan(tests => 6); + +for(1..5) { + 'threads'->create(sub { + $Test->ok(1,"Each of these should app the test number") + })->join; +} + +$Test->is_num($Test->current_test(), 5,"Should be five"); diff --git a/cpan/Test-Simple/t/todo.t b/cpan/Test-Simple/t/todo.t new file mode 100644 index 0000000000..91861be3cb --- /dev/null +++ b/cpan/Test-Simple/t/todo.t @@ -0,0 +1,157 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More; + +plan tests => 36; + + +$Why = 'Just testing the todo interface.'; + +my $is_todo; +TODO: { + local $TODO = $Why; + + fail("Expected failure"); + fail("Another expected failure"); + + $is_todo = Test::More->builder->todo; +} + +pass("This is not todo"); +ok( $is_todo, 'TB->todo' ); + + +TODO: { + local $TODO = $Why; + + fail("Yet another failure"); +} + +pass("This is still not todo"); + + +TODO: { + local $TODO = "testing that error messages don't leak out of todo"; + + ok( 'this' eq 'that', 'ok' ); + + like( 'this', qr/that/, 'like' ); + is( 'this', 'that', 'is' ); + isnt( 'this', 'this', 'isnt' ); + + can_ok('Fooble', 'yarble'); + isa_ok('Fooble', 'yarble'); + use_ok('Fooble'); + require_ok('Fooble'); +} + + +TODO: { + todo_skip "Just testing todo_skip", 2; + + fail("Just testing todo"); + die "todo_skip should prevent this"; + pass("Again"); +} + + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = join "", @_ }; + TODO: { + # perl gets the line number a little wrong on the first + # statement inside a block. + 1 == 1; +#line 74 + todo_skip "Just testing todo_skip"; + fail("So very failed"); + } + is( $warning, "todo_skip() needs to know \$how_many tests are in the ". + "block at $0 line 74\n", + 'todo_skip without $how_many warning' ); +} + +my $builder = Test::More->builder; +my $exported_to = $builder->exported_to; +TODO: { + $builder->exported_to("Wibble"); + + local $TODO = "testing \$TODO with an incorrect exported_to()"; + + fail("Just testing todo"); +} + +$builder->exported_to($exported_to); + +$builder->todo_start('Expected failures'); +fail('Testing todo_start()'); +ok 0, 'Testing todo_start() with more than one failure'; +$is_todo = $builder->todo; +$builder->todo_end; +is $is_todo, 'Expected failures', + 'todo_start should have the correct TODO message'; +ok 1, 'todo_end() should not leak TODO behavior'; + +my @nested_todo; +my ( $level1, $level2 ) = ( 'failure level 1', 'failure_level 2' ); +TODO: { + local $TODO = 'Nesting TODO'; + fail('fail 1'); + + $builder->todo_start($level1); + fail('fail 2'); + + push @nested_todo => $builder->todo; + $builder->todo_start($level2); + fail('fail 3'); + + push @nested_todo => $builder->todo; + $builder->todo_end; + fail('fail 4'); + + push @nested_todo => $builder->todo; + $builder->todo_end; + $is_todo = $builder->todo; + fail('fail 4'); +} +is_deeply \@nested_todo, [ $level1, $level2, $level1 ], + 'Nested TODO message should be correct'; +is $is_todo, 'Nesting TODO', + '... and original TODO message should be correct'; + +{ + $builder->todo_start; + fail("testing todo_start() with no message"); + my $reason = $builder->todo; + my $in_todo = $builder->in_todo; + $builder->todo_end; + + is $reason, '', " todo() reports no reason"; + ok $in_todo, " but we're in_todo()"; +} + +eval { + $builder->todo_end; +}; +is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 2; + + +{ + my($reason, $in_todo); + + TODO: { + local $TODO = ''; + $reason = $builder->todo; + $in_todo = $builder->in_todo; + } + + is $reason, ''; + ok !$in_todo, '$TODO = "" is not considered TODO'; +} diff --git a/cpan/Test-Simple/t/undef.t b/cpan/Test-Simple/t/undef.t new file mode 100644 index 0000000000..2e9201c3b4 --- /dev/null +++ b/cpan/Test-Simple/t/undef.t @@ -0,0 +1,98 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 21; + +BEGIN { $^W = 1; } + +my $warnings = ''; +local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; + +my $TB = Test::Builder->new; +sub no_warnings { + $TB->is_eq($warnings, '', ' no warnings'); + $warnings = ''; +} + +sub warnings_is { + $TB->is_eq($warnings, $_[0]); + $warnings = ''; +} + +sub warnings_like { + $TB->like($warnings, $_[0]); + $warnings = ''; +} + + +my $Filename = quotemeta $0; + + +is( undef, undef, 'undef is undef'); +no_warnings; + +isnt( undef, 'foo', 'undef isnt foo'); +no_warnings; + +isnt( undef, '', 'undef isnt an empty string' ); +isnt( undef, 0, 'undef isnt zero' ); + +Test::More->builder->is_num(undef, undef, 'is_num()'); +Test::More->builder->isnt_num(23, undef, 'isnt_num()'); + +#line 45 +like( undef, qr/.*/, 'undef is like anything' ); +warnings_like(qr/Use of uninitialized value.* at $Filename line 45\.\n/); + +eq_array( [undef, undef], [undef, 23] ); +no_warnings; + +eq_hash ( { foo => undef, bar => undef }, + { foo => undef, bar => 23 } ); +no_warnings; + +eq_set ( [undef, undef, 12], [29, undef, undef] ); +no_warnings; + + +eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } }, + { foo => undef, bar => { baz => undef, moo => 23 } } ); +no_warnings; + + +#line 64 +cmp_ok( undef, '<=', 2, ' undef <= 2' ); +warnings_like(qr/Use of uninitialized value.* at cmp_ok \[from $Filename line 64\] line 1\.\n/); + + + +my $tb = Test::More->builder; + +my $err; +$tb->failure_output(\$err); +diag(undef); +$tb->reset_outputs; + +is( $err, "# undef\n" ); +no_warnings; + + +$tb->maybe_regex(undef); +no_warnings; + + +# test-more.googlecode.com #42 +{ + is_deeply([ undef ], [ undef ]); + no_warnings; +} diff --git a/cpan/Test-Simple/t/use_ok.t b/cpan/Test-Simple/t/use_ok.t new file mode 100644 index 0000000000..4a62f3557e --- /dev/null +++ b/cpan/Test-Simple/t/use_ok.t @@ -0,0 +1,67 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = qw(../lib ../lib/Test/Simple/t/lib); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More tests => 15; + +# Using Symbol because it's core and exports lots of stuff. +{ + package Foo::one; + ::use_ok("Symbol"); + ::ok( defined &gensym, 'use_ok() no args exports defaults' ); +} + +{ + package Foo::two; + ::use_ok("Symbol", qw(qualify)); + ::ok( !defined &gensym, ' one arg, defaults overriden' ); + ::ok( defined &qualify, ' right function exported' ); +} + +{ + package Foo::three; + ::use_ok("Symbol", qw(gensym ungensym)); + ::ok( defined &gensym && defined &ungensym, ' multiple args' ); +} + +{ + package Foo::four; + my $warn; local $SIG{__WARN__} = sub { $warn .= shift; }; + ::use_ok("constant", qw(foo bar)); + ::ok( defined &foo, 'constant' ); + ::is( $warn, undef, 'no warning'); +} + +{ + package Foo::five; + ::use_ok("Symbol", 1.02); +} + +{ + package Foo::six; + ::use_ok("NoExporter", 1.02); +} + +{ + package Foo::seven; + local $SIG{__WARN__} = sub { + # Old perls will warn on X.YY_ZZ style versions. Not our problem + warn @_ unless $_[0] =~ /^Argument "\d+\.\d+_\d+" isn't numeric/; + }; + ::use_ok("Test::More", 0.47); +} + +{ + package Foo::eight; + local $SIG{__DIE__}; + ::use_ok("SigDie"); + ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved'); +} diff --git a/cpan/Test-Simple/t/useing.t b/cpan/Test-Simple/t/useing.t new file mode 100644 index 0000000000..c4ce507127 --- /dev/null +++ b/cpan/Test-Simple/t/useing.t @@ -0,0 +1,19 @@ +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 5; + +require_ok('Test::Builder'); +require_ok("Test::More"); +require_ok("Test::Simple"); + +{ + package Foo; + use Test::More import => [qw(ok is can_ok)]; + can_ok('Foo', qw(ok is can_ok)); + ok( !Foo->can('like'), 'import working properly' ); +} diff --git a/cpan/Test-Simple/t/utf8.t b/cpan/Test-Simple/t/utf8.t new file mode 100644 index 0000000000..c7e93c3ac2 --- /dev/null +++ b/cpan/Test-Simple/t/utf8.t @@ -0,0 +1,69 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; +use warnings; + +use Test::More skip_all => 'Not yet implemented'; + +my $have_perlio; +BEGIN { + # All together so Test::More sees the open discipline + $have_perlio = eval q[ + use PerlIO; + use open ':std', ':locale'; + use Test::More; + 1; + ]; +} + +use Test::More; + +if( !$have_perlio ) { + plan skip_all => "Don't have PerlIO"; +} +else { + plan tests => 5; +} + +SKIP: { + skip( "Need PerlIO for this feature", 3 ) + unless $have_perlio; + + my %handles = ( + output => \*STDOUT, + failure_output => \*STDERR, + todo_output => \*STDOUT + ); + + for my $method (keys %handles) { + my $src = $handles{$method}; + + my $dest = Test::More->builder->$method; + + is_deeply { map { $_ => 1 } PerlIO::get_layers($dest) }, + { map { $_ => 1 } PerlIO::get_layers($src) }, + "layers copied to $method"; + } +} + +SKIP: { + skip( "Can't test in general because their locale is unknown", 2 ) + unless $ENV{AUTHOR_TESTING}; + + my $uni = "\x{11e}"; + + my @warnings; + local $SIG{__WARN__} = sub { + push @warnings, @_; + }; + + is( $uni, $uni, "Testing $uni" ); + is_deeply( \@warnings, [] ); +} diff --git a/cpan/Test-Simple/t/versions.t b/cpan/Test-Simple/t/versions.t new file mode 100644 index 0000000000..e41e7ce3e0 --- /dev/null +++ b/cpan/Test-Simple/t/versions.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +# Make sure all the modules have the same version +# +# TBT has its own version system. + +use strict; +use Test::More; + +require Test::Builder; +require Test::Builder::Module; +require Test::Simple; + +my $dist_version = $Test::More::VERSION; + +like( $dist_version, qr/^ \d+ \. \d+ $/x ); +is( $dist_version, $Test::Builder::VERSION, 'Test::Builder' ); +is( $dist_version, $Test::Builder::Module::VERSION, 'TB::Module' ); +is( $dist_version, $Test::Simple::VERSION, 'Test::Simple' ); + +done_testing(4); |