From afad11a2ce2b95ce853f2a09df2cbf068be080c3 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sun, 8 Mar 2015 18:20:22 -0400 Subject: move back to a stable Test-Simple, v1.001014 --- cpan/Test-Simple/lib/Test/Builder.pm | 3089 ++++++++++++++------ cpan/Test-Simple/lib/Test/Builder/IO/Scalar.pm | 658 +++++ cpan/Test-Simple/lib/Test/Builder/Module.pm | 132 +- cpan/Test-Simple/lib/Test/Builder/Tester.pm | 240 +- cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm | 107 +- cpan/Test-Simple/lib/Test/CanFork.pm | 92 - cpan/Test-Simple/lib/Test/CanThread.pm | 119 - cpan/Test-Simple/lib/Test/More.pm | 1627 ++++++----- cpan/Test-Simple/lib/Test/More/DeepCheck.pm | 225 -- cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm | 330 --- .../lib/Test/More/DeepCheck/Tolerant.pm | 332 --- cpan/Test-Simple/lib/Test/More/Tools.pm | 506 ---- cpan/Test-Simple/lib/Test/MostlyLike.pm | 293 -- cpan/Test-Simple/lib/Test/Simple.pm | 156 +- cpan/Test-Simple/lib/Test/Stream.pm | 1184 -------- cpan/Test-Simple/lib/Test/Stream/API.pm | 696 ----- cpan/Test-Simple/lib/Test/Stream/Architecture.pod | 453 --- cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm | 373 --- cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm | 284 -- cpan/Test-Simple/lib/Test/Stream/Block.pm | 205 -- cpan/Test-Simple/lib/Test/Stream/Carp.pm | 144 - cpan/Test-Simple/lib/Test/Stream/Context.pm | 731 ----- cpan/Test-Simple/lib/Test/Stream/Event.pm | 404 --- cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm | 184 -- cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm | 206 -- cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm | 129 - cpan/Test-Simple/lib/Test/Stream/Event/Note.pm | 177 -- cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm | 392 --- cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm | 221 -- cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm | 297 -- cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm | 268 -- .../lib/Test/Stream/ExitMagic/Context.pm | 135 - cpan/Test-Simple/lib/Test/Stream/Explanation.pod | 943 ------ cpan/Test-Simple/lib/Test/Stream/Exporter.pm | 328 --- cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm | 237 -- cpan/Test-Simple/lib/Test/Stream/ForceExit.pm | 97 - cpan/Test-Simple/lib/Test/Stream/IOSets.pm | 245 -- cpan/Test-Simple/lib/Test/Stream/Meta.pm | 204 -- cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm | 210 -- cpan/Test-Simple/lib/Test/Stream/Subtest.pm | 218 -- cpan/Test-Simple/lib/Test/Stream/Tester.pm | 727 ----- cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm | 403 --- .../lib/Test/Stream/Tester/Checks/Event.pm | 197 -- cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm | 169 -- .../lib/Test/Stream/Tester/Events/Event.pm | 202 -- cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm | 215 -- cpan/Test-Simple/lib/Test/Stream/Threads.pm | 165 -- cpan/Test-Simple/lib/Test/Stream/Toolset.pm | 419 --- cpan/Test-Simple/lib/Test/Stream/Util.pm | 380 --- cpan/Test-Simple/lib/Test/Tester.pm | 600 ++-- cpan/Test-Simple/lib/Test/Tester/Capture.pm | 294 +- cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm | 67 +- cpan/Test-Simple/lib/Test/Tester/Delegate.pm | 29 +- .../Test-Simple/lib/Test/Tutorial/WritingTests.pod | 198 -- .../Test-Simple/lib/Test/Tutorial/WritingTools.pod | 300 -- cpan/Test-Simple/lib/Test/use/ok.pm | 102 +- cpan/Test-Simple/lib/ok.pm | 114 +- cpan/Test-Simple/t/00test_harness_check.t | 26 + cpan/Test-Simple/t/01-basic.t | 5 + cpan/Test-Simple/t/478-cmp_ok_hash.t | 41 + cpan/Test-Simple/t/BEGIN_require_ok.t | 27 + cpan/Test-Simple/t/BEGIN_use_ok.t | 26 + .../t/Behavior/388-threadedsubtest.load | 3 - cpan/Test-Simple/t/Behavior/388-threadedsubtest.t | 14 - cpan/Test-Simple/t/Behavior/478-cmp_ok_hash.t | 36 - cpan/Test-Simple/t/Behavior/490-inherit_exporter.t | 25 - cpan/Test-Simple/t/Behavior/CustomOutput.t | 137 - cpan/Test-Simple/t/Behavior/MonkeyPatching_diag.t | 106 - .../t/Behavior/MonkeyPatching_done_testing.t | 61 - cpan/Test-Simple/t/Behavior/MonkeyPatching_note.t | 97 - cpan/Test-Simple/t/Behavior/MonkeyPatching_ok.t | 108 - cpan/Test-Simple/t/Behavior/MonkeyPatching_plan.t | 115 - cpan/Test-Simple/t/Behavior/Munge.t | 30 - cpan/Test-Simple/t/Behavior/NotTB15.t | 48 - cpan/Test-Simple/t/Behavior/Tester2_subtest.t | 69 - cpan/Test-Simple/t/Behavior/cmp_ok_undef.t | 19 - cpan/Test-Simple/t/Behavior/cmp_ok_xor.t | 13 - cpan/Test-Simple/t/Behavior/encoding_test.t | 35 - cpan/Test-Simple/t/Behavior/event_clone_args.t | 22 - cpan/Test-Simple/t/Behavior/fork_new_end.t | 30 - cpan/Test-Simple/t/Behavior/skip_all_in_subtest.t | 31 - .../t/Behavior/skip_all_in_subtest1.load | 10 - .../t/Behavior/skip_all_in_subtest2.load | 12 - cpan/Test-Simple/t/Behavior/subtest_die.t | 35 - .../t/Behavior/threads_with_taint_mode.t | 28 - cpan/Test-Simple/t/Behavior/todo.t | 43 - cpan/Test-Simple/t/Builder/Builder.t | 30 + cpan/Test-Simple/t/Builder/carp.t | 32 + cpan/Test-Simple/t/Builder/create.t | 38 + cpan/Test-Simple/t/Builder/current_test.t | 11 + .../t/Builder/current_test_without_plan.t | 16 + cpan/Test-Simple/t/Builder/details.t | 104 + cpan/Test-Simple/t/Builder/done_testing.t | 12 + cpan/Test-Simple/t/Builder/done_testing_double.t | 47 + .../t/Builder/done_testing_plan_mismatch.t | 45 + .../t/Builder/done_testing_with_no_plan.t | 11 + .../t/Builder/done_testing_with_number.t | 12 + .../Test-Simple/t/Builder/done_testing_with_plan.t | 11 + cpan/Test-Simple/t/Builder/fork_with_new_stdout.t | 54 + cpan/Test-Simple/t/Builder/has_plan.t | 23 + cpan/Test-Simple/t/Builder/has_plan2.t | 22 + cpan/Test-Simple/t/Builder/is_fh.t | 48 + cpan/Test-Simple/t/Builder/is_passing.t | 106 + cpan/Test-Simple/t/Builder/maybe_regex.t | 60 + cpan/Test-Simple/t/Builder/no_diag.t | 8 + cpan/Test-Simple/t/Builder/no_ending.t | 21 + cpan/Test-Simple/t/Builder/no_header.t | 21 + cpan/Test-Simple/t/Builder/no_plan_at_all.t | 36 + cpan/Test-Simple/t/Builder/ok_obj.t | 29 + cpan/Test-Simple/t/Builder/output.t | 113 + cpan/Test-Simple/t/Builder/reset.t | 78 + cpan/Test-Simple/t/Builder/reset_outputs.t | 35 + cpan/Test-Simple/t/Builder/try.t | 42 + cpan/Test-Simple/t/Legacy/BEGIN_require_ok.t | 27 - cpan/Test-Simple/t/Legacy/BEGIN_use_ok.t | 26 - cpan/Test-Simple/t/Legacy/Builder/Builder.t | 30 - cpan/Test-Simple/t/Legacy/Builder/carp.t | 34 - cpan/Test-Simple/t/Legacy/Builder/create.t | 38 - cpan/Test-Simple/t/Legacy/Builder/current_test.t | 11 - .../t/Legacy/Builder/current_test_without_plan.t | 16 - cpan/Test-Simple/t/Legacy/Builder/details.t | 104 - cpan/Test-Simple/t/Legacy/Builder/done_testing.t | 12 - .../t/Legacy/Builder/done_testing_double.t | 47 - .../t/Legacy/Builder/done_testing_plan_mismatch.t | 45 - .../t/Legacy/Builder/done_testing_with_no_plan.t | 11 - .../t/Legacy/Builder/done_testing_with_number.t | 12 - .../t/Legacy/Builder/done_testing_with_plan.t | 11 - .../t/Legacy/Builder/fork_with_new_stdout.t | 48 - cpan/Test-Simple/t/Legacy/Builder/has_plan.t | 23 - cpan/Test-Simple/t/Legacy/Builder/has_plan2.t | 22 - cpan/Test-Simple/t/Legacy/Builder/is_fh.t | 48 - cpan/Test-Simple/t/Legacy/Builder/is_passing.t | 106 - cpan/Test-Simple/t/Legacy/Builder/maybe_regex.t | 60 - cpan/Test-Simple/t/Legacy/Builder/no_diag.t | 8 - cpan/Test-Simple/t/Legacy/Builder/no_ending.t | 21 - cpan/Test-Simple/t/Legacy/Builder/no_header.t | 21 - cpan/Test-Simple/t/Legacy/Builder/no_plan_at_all.t | 36 - cpan/Test-Simple/t/Legacy/Builder/ok_obj.t | 29 - cpan/Test-Simple/t/Legacy/Builder/output.t | 113 - cpan/Test-Simple/t/Legacy/Builder/reset.t | 75 - cpan/Test-Simple/t/Legacy/Builder/reset_outputs.t | 35 - cpan/Test-Simple/t/Legacy/More.t | 185 -- cpan/Test-Simple/t/Legacy/PerlIO.t | 11 - cpan/Test-Simple/t/Legacy/Simple/load.t | 13 - cpan/Test-Simple/t/Legacy/TestTester/auto.t | 32 - cpan/Test-Simple/t/Legacy/TestTester/check_tests.t | 116 - cpan/Test-Simple/t/Legacy/TestTester/depth.t | 39 - cpan/Test-Simple/t/Legacy/TestTester/is_bug.t | 31 - cpan/Test-Simple/t/Legacy/TestTester/run_test.t | 145 - cpan/Test-Simple/t/Legacy/Tester/tbt_01basic.t | 59 - cpan/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t | 58 - cpan/Test-Simple/t/Legacy/Tester/tbt_03die.t | 12 - cpan/Test-Simple/t/Legacy/Tester/tbt_04line_num.t | 8 - cpan/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t | 44 - cpan/Test-Simple/t/Legacy/Tester/tbt_06errormess.t | 120 - cpan/Test-Simple/t/Legacy/Tester/tbt_07args.t | 215 -- cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t | 16 - cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t | 21 - .../Test-Simple/t/Legacy/Tester/tbt_09do_script.pl | 13 - cpan/Test-Simple/t/Legacy/bad_plan.t | 23 - cpan/Test-Simple/t/Legacy/bail_out.t | 43 - cpan/Test-Simple/t/Legacy/buffer.t | 22 - cpan/Test-Simple/t/Legacy/c_flag.t | 21 - cpan/Test-Simple/t/Legacy/circular_data.t | 71 - cpan/Test-Simple/t/Legacy/cmp_ok.t | 86 - cpan/Test-Simple/t/Legacy/dependents.t | 44 - cpan/Test-Simple/t/Legacy/diag.t | 81 - cpan/Test-Simple/t/Legacy/died.t | 45 - .../t/Legacy/dont_overwrite_die_handler.t | 21 - cpan/Test-Simple/t/Legacy/eq_set.t | 34 - cpan/Test-Simple/t/Legacy/exit.t | 107 - cpan/Test-Simple/t/Legacy/explain.t | 27 - cpan/Test-Simple/t/Legacy/extra.t | 63 - cpan/Test-Simple/t/Legacy/extra_one.t | 52 - cpan/Test-Simple/t/Legacy/fail-like.t | 75 - cpan/Test-Simple/t/Legacy/fail-more.t | 526 ---- cpan/Test-Simple/t/Legacy/fail.t | 56 - cpan/Test-Simple/t/Legacy/fail_one.t | 43 - cpan/Test-Simple/t/Legacy/filehandles.t | 18 - cpan/Test-Simple/t/Legacy/fork.t | 22 - cpan/Test-Simple/t/Legacy/fork_die.t | 61 - cpan/Test-Simple/t/Legacy/fork_in_subtest.t | 26 - cpan/Test-Simple/t/Legacy/harness_active.t | 88 - cpan/Test-Simple/t/Legacy/import.t | 12 - cpan/Test-Simple/t/Legacy/is_deeply_dne_bug.t | 47 - cpan/Test-Simple/t/Legacy/is_deeply_fail.t | 421 --- cpan/Test-Simple/t/Legacy/is_deeply_with_threads.t | 53 - cpan/Test-Simple/t/Legacy/missing.t | 56 - cpan/Test-Simple/t/Legacy/new_ok.t | 44 - cpan/Test-Simple/t/Legacy/no_plan.t | 33 - cpan/Test-Simple/t/Legacy/no_tests.t | 44 - cpan/Test-Simple/t/Legacy/note.t | 30 - cpan/Test-Simple/t/Legacy/overload.t | 86 - cpan/Test-Simple/t/Legacy/overload_threads.t | 60 - cpan/Test-Simple/t/Legacy/plan.t | 21 - cpan/Test-Simple/t/Legacy/plan_bad.t | 37 - cpan/Test-Simple/t/Legacy/plan_is_noplan.t | 32 - cpan/Test-Simple/t/Legacy/plan_no_plan.t | 44 - cpan/Test-Simple/t/Legacy/plan_shouldnt_import.t | 16 - cpan/Test-Simple/t/Legacy/plan_skip_all.t | 12 - cpan/Test-Simple/t/Legacy/pod.t | 7 - cpan/Test-Simple/t/Legacy/require_ok.t | 22 - cpan/Test-Simple/t/Legacy/ribasushi_threads.t | 44 - cpan/Test-Simple/t/Legacy/ribasushi_threads2.t | 21 - cpan/Test-Simple/t/Legacy/simple.t | 17 - cpan/Test-Simple/t/Legacy/skip.t | 106 - cpan/Test-Simple/t/Legacy/skipall.t | 33 - cpan/Test-Simple/t/Legacy/strays.t | 27 - cpan/Test-Simple/t/Legacy/subtest/args.t | 34 - cpan/Test-Simple/t/Legacy/subtest/bail_out.t | 64 - cpan/Test-Simple/t/Legacy/subtest/basic.t | 223 -- cpan/Test-Simple/t/Legacy/subtest/die.t | 30 - cpan/Test-Simple/t/Legacy/subtest/do.t | 17 - cpan/Test-Simple/t/Legacy/subtest/exceptions.t | 67 - cpan/Test-Simple/t/Legacy/subtest/for_do_t.test | 9 - cpan/Test-Simple/t/Legacy/subtest/fork.t | 41 - cpan/Test-Simple/t/Legacy/subtest/implicit_done.t | 31 - cpan/Test-Simple/t/Legacy/subtest/line_numbers.t | 131 - cpan/Test-Simple/t/Legacy/subtest/plan.t | 49 - cpan/Test-Simple/t/Legacy/subtest/predicate.t | 166 -- cpan/Test-Simple/t/Legacy/subtest/singleton.t | 38 - cpan/Test-Simple/t/Legacy/subtest/threads.t | 17 - cpan/Test-Simple/t/Legacy/subtest/todo.t | 204 -- cpan/Test-Simple/t/Legacy/subtest/wstat.t | 24 - .../t/Legacy/tbm_doesnt_set_exported_to.t | 24 - cpan/Test-Simple/t/Legacy/test_use_ok.t | 40 - cpan/Test-Simple/t/Legacy/thread_taint.t | 5 - cpan/Test-Simple/t/Legacy/threads.t | 25 - cpan/Test-Simple/t/Legacy/todo.t | 165 -- cpan/Test-Simple/t/Legacy/undef.t | 107 - cpan/Test-Simple/t/Legacy/use_ok.t | 103 - cpan/Test-Simple/t/Legacy/useing.t | 19 - cpan/Test-Simple/t/Legacy/utf8.t | 67 - cpan/Test-Simple/t/Legacy/versions.t | 50 - cpan/Test-Simple/t/More.t | 184 ++ cpan/Test-Simple/t/MyTest.pm | 15 + cpan/Test-Simple/t/Simple/load.t | 13 + cpan/Test-Simple/t/SmallTest.pm | 35 + cpan/Test-Simple/t/Test-Builder.t | 10 - cpan/Test-Simple/t/Test-More-DeepCheck.t | 7 - cpan/Test-Simple/t/Test-More.t | 29 - cpan/Test-Simple/t/Test-MostlyLike.t | 159 - cpan/Test-Simple/t/Test-Simple.t | 24 - cpan/Test-Simple/t/Test-Stream-API.t | 323 -- cpan/Test-Simple/t/Test-Stream-ArrayBase-Meta.t | 10 - cpan/Test-Simple/t/Test-Stream-ArrayBase.t | 97 - cpan/Test-Simple/t/Test-Stream-Block.t | 108 - cpan/Test-Simple/t/Test-Stream-Carp.t | 53 - cpan/Test-Simple/t/Test-Stream-Event-Diag.t | 26 - cpan/Test-Simple/t/Test-Stream-Event-Finish.t | 7 - cpan/Test-Simple/t/Test-Stream-Event-Note.t | 19 - cpan/Test-Simple/t/Test-Stream-Event.t | 30 - cpan/Test-Simple/t/Test-Stream-ExitMagic-Context.t | 8 - cpan/Test-Simple/t/Test-Stream-Exporter-Meta.t | 9 - cpan/Test-Simple/t/Test-Stream-Exporter.t | 122 - cpan/Test-Simple/t/Test-Stream-ForceExit.t | 69 - cpan/Test-Simple/t/Test-Stream-IOSets.t | 31 - cpan/Test-Simple/t/Test-Stream-Meta.t | 16 - cpan/Test-Simple/t/Test-Stream-PackageUtil.t | 38 - cpan/Test-Simple/t/Test-Stream-Tester-Grab.t | 11 - cpan/Test-Simple/t/Test-Stream-Tester.t | 140 - cpan/Test-Simple/t/Test-Stream-Toolset.t | 11 - cpan/Test-Simple/t/Test-Stream-Util.t | 45 - cpan/Test-Simple/t/Test-Tester-Capture.t | 9 - cpan/Test-Simple/t/Test-Tester.t | 9 - cpan/Test-Simple/t/Test-use-ok.t | 25 - cpan/Test-Simple/t/Tester/tbt_01basic.t | 59 + cpan/Test-Simple/t/Tester/tbt_02fhrestore.t | 58 + cpan/Test-Simple/t/Tester/tbt_03die.t | 12 + cpan/Test-Simple/t/Tester/tbt_04line_num.t | 8 + cpan/Test-Simple/t/Tester/tbt_05faildiag.t | 44 + cpan/Test-Simple/t/Tester/tbt_06errormess.t | 120 + cpan/Test-Simple/t/Tester/tbt_07args.t | 215 ++ cpan/Test-Simple/t/Tester/tbt_08subtest.t | 16 + cpan/Test-Simple/t/Tester/tbt_09do.t | 21 + cpan/Test-Simple/t/Tester/tbt_09do_script.pl | 13 + cpan/Test-Simple/t/auto.t | 30 + cpan/Test-Simple/t/bad_plan.t | 23 + cpan/Test-Simple/t/bail_out.t | 43 + cpan/Test-Simple/t/buffer.t | 22 + cpan/Test-Simple/t/c_flag.t | 21 + cpan/Test-Simple/t/capture.t | 32 + cpan/Test-Simple/t/check_tests.t | 117 + cpan/Test-Simple/t/circular_data.t | 71 + cpan/Test-Simple/t/cmp_ok.t | 86 + cpan/Test-Simple/t/dependents.t | 44 + cpan/Test-Simple/t/depth.t | 31 + cpan/Test-Simple/t/diag.t | 81 + cpan/Test-Simple/t/died.t | 45 + cpan/Test-Simple/t/dont_overwrite_die_handler.t | 20 + cpan/Test-Simple/t/eq_set.t | 34 + cpan/Test-Simple/t/exit.t | 117 + cpan/Test-Simple/t/explain.t | 27 + cpan/Test-Simple/t/extra.t | 60 + cpan/Test-Simple/t/extra_one.t | 52 + cpan/Test-Simple/t/fail-like.t | 77 + cpan/Test-Simple/t/fail-more.t | 521 ++++ cpan/Test-Simple/t/fail.t | 56 + cpan/Test-Simple/t/fail_one.t | 43 + cpan/Test-Simple/t/filehandles.t | 18 + cpan/Test-Simple/t/fork.t | 32 + cpan/Test-Simple/t/harness_active.t | 88 + cpan/Test-Simple/t/import.t | 12 + cpan/Test-Simple/t/is_deeply_dne_bug.t | 47 + cpan/Test-Simple/t/is_deeply_fail.t | 421 +++ cpan/Test-Simple/t/is_deeply_with_threads.t | 65 + cpan/Test-Simple/t/lib/MyTest.pm | 15 - cpan/Test-Simple/t/lib/SmallTest.pm | 35 - cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm | 2 +- cpan/Test-Simple/t/missing.t | 56 + cpan/Test-Simple/t/new_ok.t | 42 + cpan/Test-Simple/t/no_plan.t | 33 + cpan/Test-Simple/t/no_tests.t | 44 + cpan/Test-Simple/t/note.t | 30 + cpan/Test-Simple/t/overload.t | 86 + cpan/Test-Simple/t/overload_threads.t | 60 + cpan/Test-Simple/t/plan.t | 21 + cpan/Test-Simple/t/plan_bad.t | 37 + cpan/Test-Simple/t/plan_is_noplan.t | 32 + cpan/Test-Simple/t/plan_no_plan.t | 40 + cpan/Test-Simple/t/plan_shouldnt_import.t | 16 + cpan/Test-Simple/t/plan_skip_all.t | 12 + cpan/Test-Simple/t/require_ok.t | 29 + cpan/Test-Simple/t/run_test.t | 145 + cpan/Test-Simple/t/simple.t | 17 + cpan/Test-Simple/t/skip.t | 98 + cpan/Test-Simple/t/skipall.t | 33 + cpan/Test-Simple/t/subtest/args.t | 33 + cpan/Test-Simple/t/subtest/bail_out.t | 59 + cpan/Test-Simple/t/subtest/basic.t | 214 ++ cpan/Test-Simple/t/subtest/die.t | 30 + cpan/Test-Simple/t/subtest/do.t | 17 + cpan/Test-Simple/t/subtest/exceptions.t | 63 + cpan/Test-Simple/t/subtest/for_do_t.test | 9 + cpan/Test-Simple/t/subtest/fork.t | 51 + cpan/Test-Simple/t/subtest/implicit_done.t | 31 + cpan/Test-Simple/t/subtest/line_numbers.t | 130 + cpan/Test-Simple/t/subtest/plan.t | 49 + cpan/Test-Simple/t/subtest/predicate.t | 166 ++ cpan/Test-Simple/t/subtest/singleton.t | 38 + cpan/Test-Simple/t/subtest/threads.t | 25 + cpan/Test-Simple/t/subtest/todo.t | 200 ++ cpan/Test-Simple/t/subtest/wstat.t | 24 + cpan/Test-Simple/t/tbm_doesnt_set_exported_to.t | 24 + cpan/Test-Simple/t/thread_taint.t | 5 + cpan/Test-Simple/t/threads.t | 33 + cpan/Test-Simple/t/todo.t | 157 + cpan/Test-Simple/t/undef.t | 98 + cpan/Test-Simple/t/use_ok.t | 103 + cpan/Test-Simple/t/useing.t | 19 + cpan/Test-Simple/t/utf8.t | 67 + cpan/Test-Simple/t/versions.t | 28 + cpan/Test-Simple/t/xt/dependents.t | 51 + cpan/Test-Simple/t/xxx-changes_updated.t | 20 + 354 files changed, 11263 insertions(+), 26664 deletions(-) create mode 100644 cpan/Test-Simple/lib/Test/Builder/IO/Scalar.pm delete mode 100644 cpan/Test-Simple/lib/Test/CanFork.pm delete mode 100644 cpan/Test-Simple/lib/Test/CanThread.pm delete mode 100644 cpan/Test-Simple/lib/Test/More/DeepCheck.pm delete mode 100644 cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm delete mode 100644 cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm delete mode 100644 cpan/Test-Simple/lib/Test/More/Tools.pm delete mode 100644 cpan/Test-Simple/lib/Test/MostlyLike.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/API.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Architecture.pod delete mode 100644 cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Block.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Carp.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Context.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event/Note.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Explanation.pod delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Exporter.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/ForceExit.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/IOSets.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Meta.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Subtest.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Tester.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Threads.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Toolset.pm delete mode 100644 cpan/Test-Simple/lib/Test/Stream/Util.pm delete mode 100644 cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod delete mode 100644 cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod create mode 100644 cpan/Test-Simple/t/00test_harness_check.t create mode 100644 cpan/Test-Simple/t/01-basic.t create mode 100644 cpan/Test-Simple/t/478-cmp_ok_hash.t create mode 100644 cpan/Test-Simple/t/BEGIN_require_ok.t create mode 100644 cpan/Test-Simple/t/BEGIN_use_ok.t delete mode 100644 cpan/Test-Simple/t/Behavior/388-threadedsubtest.load delete mode 100644 cpan/Test-Simple/t/Behavior/388-threadedsubtest.t delete mode 100644 cpan/Test-Simple/t/Behavior/478-cmp_ok_hash.t delete mode 100644 cpan/Test-Simple/t/Behavior/490-inherit_exporter.t delete mode 100644 cpan/Test-Simple/t/Behavior/CustomOutput.t delete mode 100644 cpan/Test-Simple/t/Behavior/MonkeyPatching_diag.t delete mode 100644 cpan/Test-Simple/t/Behavior/MonkeyPatching_done_testing.t delete mode 100644 cpan/Test-Simple/t/Behavior/MonkeyPatching_note.t delete mode 100644 cpan/Test-Simple/t/Behavior/MonkeyPatching_ok.t delete mode 100644 cpan/Test-Simple/t/Behavior/MonkeyPatching_plan.t delete mode 100644 cpan/Test-Simple/t/Behavior/Munge.t delete mode 100644 cpan/Test-Simple/t/Behavior/NotTB15.t delete mode 100644 cpan/Test-Simple/t/Behavior/Tester2_subtest.t delete mode 100644 cpan/Test-Simple/t/Behavior/cmp_ok_undef.t delete mode 100644 cpan/Test-Simple/t/Behavior/cmp_ok_xor.t delete mode 100644 cpan/Test-Simple/t/Behavior/encoding_test.t delete mode 100644 cpan/Test-Simple/t/Behavior/event_clone_args.t delete mode 100644 cpan/Test-Simple/t/Behavior/fork_new_end.t delete mode 100644 cpan/Test-Simple/t/Behavior/skip_all_in_subtest.t delete mode 100644 cpan/Test-Simple/t/Behavior/skip_all_in_subtest1.load delete mode 100644 cpan/Test-Simple/t/Behavior/skip_all_in_subtest2.load delete mode 100644 cpan/Test-Simple/t/Behavior/subtest_die.t delete mode 100644 cpan/Test-Simple/t/Behavior/threads_with_taint_mode.t delete mode 100644 cpan/Test-Simple/t/Behavior/todo.t create mode 100644 cpan/Test-Simple/t/Builder/Builder.t create mode 100644 cpan/Test-Simple/t/Builder/carp.t create mode 100644 cpan/Test-Simple/t/Builder/create.t create mode 100644 cpan/Test-Simple/t/Builder/current_test.t create mode 100644 cpan/Test-Simple/t/Builder/current_test_without_plan.t create mode 100644 cpan/Test-Simple/t/Builder/details.t create mode 100644 cpan/Test-Simple/t/Builder/done_testing.t create mode 100644 cpan/Test-Simple/t/Builder/done_testing_double.t create mode 100644 cpan/Test-Simple/t/Builder/done_testing_plan_mismatch.t create mode 100644 cpan/Test-Simple/t/Builder/done_testing_with_no_plan.t create mode 100644 cpan/Test-Simple/t/Builder/done_testing_with_number.t create mode 100644 cpan/Test-Simple/t/Builder/done_testing_with_plan.t create mode 100644 cpan/Test-Simple/t/Builder/fork_with_new_stdout.t create mode 100644 cpan/Test-Simple/t/Builder/has_plan.t create mode 100644 cpan/Test-Simple/t/Builder/has_plan2.t create mode 100644 cpan/Test-Simple/t/Builder/is_fh.t create mode 100644 cpan/Test-Simple/t/Builder/is_passing.t create mode 100644 cpan/Test-Simple/t/Builder/maybe_regex.t create mode 100644 cpan/Test-Simple/t/Builder/no_diag.t create mode 100644 cpan/Test-Simple/t/Builder/no_ending.t create mode 100644 cpan/Test-Simple/t/Builder/no_header.t create mode 100644 cpan/Test-Simple/t/Builder/no_plan_at_all.t create mode 100644 cpan/Test-Simple/t/Builder/ok_obj.t create mode 100644 cpan/Test-Simple/t/Builder/output.t create mode 100644 cpan/Test-Simple/t/Builder/reset.t create mode 100644 cpan/Test-Simple/t/Builder/reset_outputs.t create mode 100644 cpan/Test-Simple/t/Builder/try.t delete mode 100644 cpan/Test-Simple/t/Legacy/BEGIN_require_ok.t delete mode 100644 cpan/Test-Simple/t/Legacy/BEGIN_use_ok.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/Builder.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/carp.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/create.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/current_test.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/current_test_without_plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/details.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/done_testing.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/done_testing_with_number.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/has_plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/has_plan2.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/is_fh.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/is_passing.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/maybe_regex.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/no_diag.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/no_ending.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/no_header.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/no_plan_at_all.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/ok_obj.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/output.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/reset.t delete mode 100644 cpan/Test-Simple/t/Legacy/Builder/reset_outputs.t delete mode 100644 cpan/Test-Simple/t/Legacy/More.t delete mode 100644 cpan/Test-Simple/t/Legacy/PerlIO.t delete mode 100644 cpan/Test-Simple/t/Legacy/Simple/load.t delete mode 100644 cpan/Test-Simple/t/Legacy/TestTester/auto.t delete mode 100644 cpan/Test-Simple/t/Legacy/TestTester/check_tests.t delete mode 100644 cpan/Test-Simple/t/Legacy/TestTester/depth.t delete mode 100644 cpan/Test-Simple/t/Legacy/TestTester/is_bug.t delete mode 100644 cpan/Test-Simple/t/Legacy/TestTester/run_test.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_01basic.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_03die.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_04line_num.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_06errormess.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_07args.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t delete mode 100644 cpan/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl delete mode 100644 cpan/Test-Simple/t/Legacy/bad_plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/bail_out.t delete mode 100644 cpan/Test-Simple/t/Legacy/buffer.t delete mode 100644 cpan/Test-Simple/t/Legacy/c_flag.t delete mode 100644 cpan/Test-Simple/t/Legacy/circular_data.t delete mode 100644 cpan/Test-Simple/t/Legacy/cmp_ok.t delete mode 100644 cpan/Test-Simple/t/Legacy/dependents.t delete mode 100644 cpan/Test-Simple/t/Legacy/diag.t delete mode 100644 cpan/Test-Simple/t/Legacy/died.t delete mode 100644 cpan/Test-Simple/t/Legacy/dont_overwrite_die_handler.t delete mode 100644 cpan/Test-Simple/t/Legacy/eq_set.t delete mode 100644 cpan/Test-Simple/t/Legacy/exit.t delete mode 100644 cpan/Test-Simple/t/Legacy/explain.t delete mode 100644 cpan/Test-Simple/t/Legacy/extra.t delete mode 100644 cpan/Test-Simple/t/Legacy/extra_one.t delete mode 100644 cpan/Test-Simple/t/Legacy/fail-like.t delete mode 100644 cpan/Test-Simple/t/Legacy/fail-more.t delete mode 100644 cpan/Test-Simple/t/Legacy/fail.t delete mode 100644 cpan/Test-Simple/t/Legacy/fail_one.t delete mode 100644 cpan/Test-Simple/t/Legacy/filehandles.t delete mode 100644 cpan/Test-Simple/t/Legacy/fork.t delete mode 100644 cpan/Test-Simple/t/Legacy/fork_die.t delete mode 100644 cpan/Test-Simple/t/Legacy/fork_in_subtest.t delete mode 100644 cpan/Test-Simple/t/Legacy/harness_active.t delete mode 100644 cpan/Test-Simple/t/Legacy/import.t delete mode 100644 cpan/Test-Simple/t/Legacy/is_deeply_dne_bug.t delete mode 100644 cpan/Test-Simple/t/Legacy/is_deeply_fail.t delete mode 100644 cpan/Test-Simple/t/Legacy/is_deeply_with_threads.t delete mode 100644 cpan/Test-Simple/t/Legacy/missing.t delete mode 100644 cpan/Test-Simple/t/Legacy/new_ok.t delete mode 100644 cpan/Test-Simple/t/Legacy/no_plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/no_tests.t delete mode 100644 cpan/Test-Simple/t/Legacy/note.t delete mode 100644 cpan/Test-Simple/t/Legacy/overload.t delete mode 100644 cpan/Test-Simple/t/Legacy/overload_threads.t delete mode 100644 cpan/Test-Simple/t/Legacy/plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/plan_bad.t delete mode 100644 cpan/Test-Simple/t/Legacy/plan_is_noplan.t delete mode 100644 cpan/Test-Simple/t/Legacy/plan_no_plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/plan_shouldnt_import.t delete mode 100644 cpan/Test-Simple/t/Legacy/plan_skip_all.t delete mode 100644 cpan/Test-Simple/t/Legacy/pod.t delete mode 100644 cpan/Test-Simple/t/Legacy/require_ok.t delete mode 100644 cpan/Test-Simple/t/Legacy/ribasushi_threads.t delete mode 100644 cpan/Test-Simple/t/Legacy/ribasushi_threads2.t delete mode 100644 cpan/Test-Simple/t/Legacy/simple.t delete mode 100644 cpan/Test-Simple/t/Legacy/skip.t delete mode 100644 cpan/Test-Simple/t/Legacy/skipall.t delete mode 100644 cpan/Test-Simple/t/Legacy/strays.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/args.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/bail_out.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/basic.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/die.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/do.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/exceptions.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/for_do_t.test delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/fork.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/implicit_done.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/line_numbers.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/plan.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/predicate.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/singleton.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/threads.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/todo.t delete mode 100644 cpan/Test-Simple/t/Legacy/subtest/wstat.t delete mode 100644 cpan/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t delete mode 100644 cpan/Test-Simple/t/Legacy/test_use_ok.t delete mode 100644 cpan/Test-Simple/t/Legacy/thread_taint.t delete mode 100644 cpan/Test-Simple/t/Legacy/threads.t delete mode 100644 cpan/Test-Simple/t/Legacy/todo.t delete mode 100644 cpan/Test-Simple/t/Legacy/undef.t delete mode 100644 cpan/Test-Simple/t/Legacy/use_ok.t delete mode 100644 cpan/Test-Simple/t/Legacy/useing.t delete mode 100644 cpan/Test-Simple/t/Legacy/utf8.t delete mode 100644 cpan/Test-Simple/t/Legacy/versions.t create mode 100644 cpan/Test-Simple/t/More.t create mode 100644 cpan/Test-Simple/t/MyTest.pm create mode 100644 cpan/Test-Simple/t/Simple/load.t create mode 100644 cpan/Test-Simple/t/SmallTest.pm delete mode 100644 cpan/Test-Simple/t/Test-Builder.t delete mode 100644 cpan/Test-Simple/t/Test-More-DeepCheck.t delete mode 100644 cpan/Test-Simple/t/Test-More.t delete mode 100644 cpan/Test-Simple/t/Test-MostlyLike.t delete mode 100644 cpan/Test-Simple/t/Test-Simple.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-API.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-ArrayBase-Meta.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-ArrayBase.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Block.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Carp.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Event-Diag.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Event-Finish.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Event-Note.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Event.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-ExitMagic-Context.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Exporter-Meta.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Exporter.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-ForceExit.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-IOSets.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Meta.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-PackageUtil.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Tester-Grab.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Tester.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Toolset.t delete mode 100644 cpan/Test-Simple/t/Test-Stream-Util.t delete mode 100644 cpan/Test-Simple/t/Test-Tester-Capture.t delete mode 100644 cpan/Test-Simple/t/Test-Tester.t delete mode 100644 cpan/Test-Simple/t/Test-use-ok.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_01basic.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_02fhrestore.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_03die.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_04line_num.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_05faildiag.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_06errormess.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_07args.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_08subtest.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_09do.t create mode 100644 cpan/Test-Simple/t/Tester/tbt_09do_script.pl create mode 100644 cpan/Test-Simple/t/auto.t create mode 100644 cpan/Test-Simple/t/bad_plan.t create mode 100644 cpan/Test-Simple/t/bail_out.t create mode 100644 cpan/Test-Simple/t/buffer.t create mode 100644 cpan/Test-Simple/t/c_flag.t create mode 100644 cpan/Test-Simple/t/capture.t create mode 100644 cpan/Test-Simple/t/check_tests.t create mode 100644 cpan/Test-Simple/t/circular_data.t create mode 100644 cpan/Test-Simple/t/cmp_ok.t create mode 100644 cpan/Test-Simple/t/dependents.t create mode 100644 cpan/Test-Simple/t/depth.t create mode 100644 cpan/Test-Simple/t/diag.t create mode 100644 cpan/Test-Simple/t/died.t create mode 100644 cpan/Test-Simple/t/dont_overwrite_die_handler.t create mode 100644 cpan/Test-Simple/t/eq_set.t create mode 100644 cpan/Test-Simple/t/exit.t create mode 100644 cpan/Test-Simple/t/explain.t create mode 100644 cpan/Test-Simple/t/extra.t create mode 100644 cpan/Test-Simple/t/extra_one.t create mode 100644 cpan/Test-Simple/t/fail-like.t create mode 100644 cpan/Test-Simple/t/fail-more.t create mode 100644 cpan/Test-Simple/t/fail.t create mode 100644 cpan/Test-Simple/t/fail_one.t create mode 100644 cpan/Test-Simple/t/filehandles.t create mode 100644 cpan/Test-Simple/t/fork.t create mode 100644 cpan/Test-Simple/t/harness_active.t create mode 100644 cpan/Test-Simple/t/import.t create mode 100644 cpan/Test-Simple/t/is_deeply_dne_bug.t create mode 100644 cpan/Test-Simple/t/is_deeply_fail.t create mode 100644 cpan/Test-Simple/t/is_deeply_with_threads.t delete mode 100644 cpan/Test-Simple/t/lib/MyTest.pm delete mode 100644 cpan/Test-Simple/t/lib/SmallTest.pm create mode 100644 cpan/Test-Simple/t/missing.t create mode 100644 cpan/Test-Simple/t/new_ok.t create mode 100644 cpan/Test-Simple/t/no_plan.t create mode 100644 cpan/Test-Simple/t/no_tests.t create mode 100644 cpan/Test-Simple/t/note.t create mode 100644 cpan/Test-Simple/t/overload.t create mode 100644 cpan/Test-Simple/t/overload_threads.t create mode 100644 cpan/Test-Simple/t/plan.t create mode 100644 cpan/Test-Simple/t/plan_bad.t create mode 100644 cpan/Test-Simple/t/plan_is_noplan.t create mode 100644 cpan/Test-Simple/t/plan_no_plan.t create mode 100644 cpan/Test-Simple/t/plan_shouldnt_import.t create mode 100644 cpan/Test-Simple/t/plan_skip_all.t create mode 100644 cpan/Test-Simple/t/require_ok.t create mode 100644 cpan/Test-Simple/t/run_test.t create mode 100644 cpan/Test-Simple/t/simple.t create mode 100644 cpan/Test-Simple/t/skip.t create mode 100644 cpan/Test-Simple/t/skipall.t create mode 100644 cpan/Test-Simple/t/subtest/args.t create mode 100644 cpan/Test-Simple/t/subtest/bail_out.t create mode 100644 cpan/Test-Simple/t/subtest/basic.t create mode 100644 cpan/Test-Simple/t/subtest/die.t create mode 100644 cpan/Test-Simple/t/subtest/do.t create mode 100644 cpan/Test-Simple/t/subtest/exceptions.t create mode 100644 cpan/Test-Simple/t/subtest/for_do_t.test create mode 100644 cpan/Test-Simple/t/subtest/fork.t create mode 100644 cpan/Test-Simple/t/subtest/implicit_done.t create mode 100644 cpan/Test-Simple/t/subtest/line_numbers.t create mode 100644 cpan/Test-Simple/t/subtest/plan.t create mode 100644 cpan/Test-Simple/t/subtest/predicate.t create mode 100644 cpan/Test-Simple/t/subtest/singleton.t create mode 100644 cpan/Test-Simple/t/subtest/threads.t create mode 100644 cpan/Test-Simple/t/subtest/todo.t create mode 100644 cpan/Test-Simple/t/subtest/wstat.t create mode 100644 cpan/Test-Simple/t/tbm_doesnt_set_exported_to.t create mode 100644 cpan/Test-Simple/t/thread_taint.t create mode 100644 cpan/Test-Simple/t/threads.t create mode 100644 cpan/Test-Simple/t/todo.t create mode 100644 cpan/Test-Simple/t/undef.t create mode 100644 cpan/Test-Simple/t/use_ok.t create mode 100644 cpan/Test-Simple/t/useing.t create mode 100644 cpan/Test-Simple/t/utf8.t create mode 100644 cpan/Test-Simple/t/versions.t create mode 100644 cpan/Test-Simple/t/xt/dependents.t create mode 100644 cpan/Test-Simple/t/xxx-changes_updated.t (limited to 'cpan') diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm index 11dadc7140..a8e7bd95b1 100644 --- a/cpan/Test-Simple/lib/Test/Builder.pm +++ b/cpan/Test-Simple/lib/Test/Builder.pm @@ -1,713 +1,1549 @@ package Test::Builder; -use 5.008001; +use 5.006; use strict; use warnings; -our $VERSION = '1.301001_098'; +our $VERSION = '1.001014'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +BEGIN { + if( $] < 5.008 ) { + require Test::Builder::IO::Scalar; + } +} -use Test::Stream 1.301001 qw/ -internal STATE_LEGACY STATE_PLAN STATE_COUNT /; -use Test::Stream::Toolset; -use Test::Stream::Context; -use Test::Stream::Carp qw/confess/; -use Test::Stream::Meta qw/MODERN/; - -use Test::Stream::Util qw/try protect unoverload_str is_regex/; -use Scalar::Util qw/blessed reftype/; - -use Test::More::Tools; +# Make Test::Builder thread-safe for ithreads. BEGIN { - my $meta = Test::Stream::Meta->is_tester('main'); - Test::Stream->shared->set_use_legacy(1) - unless $meta && $meta->[MODERN]; -} + 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 + # occasionally 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 ); + } -# The mostly-singleton, and other package vars. -our $Test = Test::Builder->new; -our $_ORIG_Test = $Test; -our $Level = 1; + $_[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 ); + } -sub ctx { - my $self = shift || die "No self in context"; - my ($add) = @_; - my $ctx = Test::Stream::Context::context(2 + ($add || 0), $self->{stream}); - if (defined $self->{Todo}) { - $ctx->set_in_todo(1); - $ctx->set_todo($self->{Todo}); - $ctx->set_diag_todo(1); + 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 }; } - return $ctx; } -sub stream { - my $self = shift; - return $self->{stream} || Test::Stream->shared; -} +=head1 NAME -sub depth { $_[0]->{depth} || 0 } +Test::Builder - Backend for building test libraries -# This is only for unit tests at this point. -sub _ending { - my $self = shift; - my ($ctx) = @_; - require Test::Stream::ExitMagic; - $self->{stream}->set_no_ending(0); - Test::Stream::ExitMagic->new->do_magic($self->{stream}, $ctx); -} - -my %WARNED; -our $CTX; -our %ORIG = ( - ok => \&ok, - diag => \&diag, - note => \¬e, - plan => \&plan, - done_testing => \&done_testing, -); +=head1 SYNOPSIS -sub WARN_OF_OVERRIDE { - my ($sub, $ctx) = @_; + package My::Test::Module; + use base 'Test::Builder::Module'; - return unless $ctx->modern; - my $old = $ORIG{$sub}; - # Use package instead of self, we want replaced subs, not subclass overrides. - my $new = __PACKAGE__->can($sub); + my $CLASS = __PACKAGE__; - return if $new == $old; + sub ok { + my($test, $name) = @_; + my $tb = $CLASS->builder; - require B; - my $o = B::svref_2object($new); - my $gv = $o->GV; - my $st = $o->START; - my $name = $gv->NAME; - my $pkg = $gv->STASH->NAME; - my $line = $st->line; - my $file = $st->file; + $tb->ok($test, $name); + } - warn <<" EOT" unless $WARNED{"$pkg $name $file $line"}++; -******************************************************************************* -Something monkeypatched Test::Builder::$sub()! -The new sub is '$pkg\::$name' defined in $file around line $line. -In the near future monkeypatching Test::Builder::ok() will no longer work -as expected. -******************************************************************************* - EOT -} +=head1 DESCRIPTION +L and L have proven to be popular testing modules, +but they're not always flexible enough. Test::Builder provides a +building block upon which to write your own test libraries I. -#################### -# {{{ Constructors # -#################### +=head2 Construction -sub new { - my $class = shift; - my %params = @_; - $Test ||= $class->create(shared_stream => 1); +=over 4 + +=item B + + my $Test = Test::Builder->new; + +Returns a Test::Builder object representing the current state of the +test. + +Since you only run one test per program C always returns the same +Test::Builder object. No matter how many times you call C, you're +getting the same object. This is called a singleton. This is done so that +multiple modules share such global information as the test counter and +where test output is going. + +If you want a completely new Test::Builder object different from the +singleton, use C. +=cut + +our $Test = Test::Builder->new; + +sub new { + my($class) = shift; + $Test ||= $class->create; return $Test; } +=item B + + my $Test = Test::Builder->create; + +Ok, so there can be more than one Test::Builder object and this is how +you get it. You might use this instead of C if you're testing +a Test::Builder based module, but otherwise you probably want C. + +B: the implementation is not complete. C, for example, is +still shared amongst B Test::Builder objects, even ones created using +this method. Also, the method name may change in the future. + +=cut + sub create { - my $class = shift; - my %params = @_; + my $class = shift; my $self = bless {}, $class; - $self->reset(%params); + $self->reset; return $self; } + # Copy an object, currently a shallow. # This does *not* bless the destination. This keeps the destructor from # firing when we're just storing a copy of the object to restore later. sub _copy { - my ($src, $dest) = @_; + my($src, $dest) = @_; + %$dest = %$src; + _share_keys($dest); + return; } -#################### -# }}} Constructors # -#################### -############################# -# {{{ Children and subtests # -############################# +=item B -sub subtest { - my $self = shift; - my $ctx = $self->ctx(); - require Test::Stream::Subtest; - return Test::Stream::Subtest::subtest(@_); -} + my $child = $builder->child($name_of_child); + $child->plan( tests => 4 ); + $child->ok(some_code()); + ... + $child->finalize; + +Returns a new instance of C. Any output from this child will +be indented four spaces more than the parent's indentation. When done, the +C method I be called explicitly. + +Trying to create a new child with a previous child still active (i.e., +C not called) will C. + +Trying to run a test when you have an open child will also C and cause +the test suite to fail. + +=cut sub child { my( $self, $name ) = @_; - my $ctx = $self->ctx; - - if ($self->{child}) { - my $cname = $self->{child}->{Name}; - $ctx->throw("You already have a child named ($cname) running"); + if( $self->{Child_Name} ) { + $self->croak("You already have a child named ($self->{Child_Name}) running"); } - $name ||= "Child of " . $self->{Name}; - my $stream = $self->{stream} || Test::Stream->shared; - $ctx->subtest_start($name, parent_todo => $ctx->in_todo); + my $parent_in_todo = $self->in_todo; - my $child = bless { - %$self, - '?' => $?, - parent => $self, - }; + # Clear $TODO for the child. + my $orig_TODO = $self->find_TODO(undef, 1, undef); + + my $class = ref $self; + my $child = $class->create; + + # Add to our indentation + $child->_indent( $self->_indent . ' ' ); + + # Make the child use the same outputs as the parent + for my $method (qw(output failure_output todo_output)) { + $child->$method( $self->$method ); + } - $? = 0; - $child->{Name} = $name; - $self->{child} = $child; - Scalar::Util::weaken($self->{child}); + # Ensure the child understands if they're inside a TODO + if( $parent_in_todo ) { + $child->failure_output( $self->todo_output ); + } + # This will be reset in finalize. We do this here lest one child failure + # cause all children to fail. + $child->{Child_Error} = $?; + $? = 0; + $child->{Parent} = $self; + $child->{Parent_TODO} = $orig_TODO; + $child->{Name} = $name || "Child of " . $self->name; + $self->{Child_Name} = $child->name; return $child; } -sub finalize { - my $self = shift; - return unless $self->{parent}; +=item B + + $builder->subtest($name, \&subtests, @args); - my $ctx = $self->ctx; +See documentation of C in Test::More. + +C also, and optionally, accepts arguments which will be passed to the +subtests reference. + +=cut + +sub subtest { + my $self = shift; + my($name, $subtests, @args) = @_; - if ($self->{child}) { - my $cname = $self->{child}->{Name}; - $ctx->throw("Can't call finalize() with child ($cname) active"); + if ('CODE' ne ref $subtests) { + $self->croak("subtest()'s second argument must be a code ref"); } - $self->_ending($ctx); - my $passing = $ctx->stream->is_passing; - my $count = $ctx->stream->count; - my $name = $self->{Name}; + # Turn the child into the parent so anyone who has stored a copy of + # the Test::Builder singleton will get the child. + my $error; + my $child; + my $parent = {}; + { + # child() calls reset() which sets $Level to 1, so we localize + # $Level first to limit the scope of the reset to the subtest. + local $Test::Builder::Level = $Test::Builder::Level + 1; + + # Store the guts of $self as $parent and turn $child into $self. + $child = $self->child($name); + _copy($self, $parent); + _copy($child, $self); + + my $run_the_subtests = sub { + # Add subtest name for clarification of starting point + $self->note("Subtest: $name"); + $subtests->(@args); + $self->done_testing unless $self->_plan_handled; + 1; + }; + + if( !eval { $run_the_subtests->() } ) { + $error = $@; + } + } - my $stream = $self->{stream} || Test::Stream->shared; + # Restore the parent and the copied child. + _copy($self, $child); + _copy($parent, $self); - my $parent = $self->parent; - $self->{parent}->{child} = undef; - $self->{parent} = undef; + # Restore the parent's $TODO + $self->find_TODO(undef, 1, $child->{Parent_TODO}); - $? = $self->{'?'}; + # Die *after* we restore the parent. + die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; - my $st = $ctx->subtest_stop($name); + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $finalize = $child->finalize; - $parent->ctx->subtest( - # Stuff from ok (most of this gets initialized inside) - undef, # real_bool, gets set properly by initializer - $st->{name}, # name - undef, # diag - undef, # bool - undef, # level + $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out}; - # Subtest specific stuff - $st->{state}, - $st->{events}, - $st->{exception}, - $st->{early_return}, - $st->{delayed}, - $st->{instant}, - ); + return $finalize; } -sub in_subtest { - my $self = shift; - my $ctx = $self->ctx; - return scalar @{$ctx->stream->subtests}; -} +=begin _private -sub parent { $_[0]->{parent} } -sub name { $_[0]->{Name} } +=item B<_plan_handled> -sub DESTROY { - my $self = shift; - return unless $self->{parent}; - return if $self->{Skip_All}; - $self->{parent}->is_passing(0); - my $name = $self->{Name}; - die "Child ($name) exited without calling finalize()"; -} + if ( $Test->_plan_handled ) { ... } -############################# -# }}} Children and subtests # -############################# +Returns true if the developer has explicitly handled the plan via: -##################################### -# {{{ stuff for TODO status # -##################################### +=over 4 -sub find_TODO { - my ($self, $pack, $set, $new_value) = @_; - - unless ($pack) { - if (my $ctx = Test::Stream::Context->peek) { - $pack = $ctx->package; - my $old = $ctx->todo; - $ctx->set_todo($new_value) if $set; - return $old; - } +=item * Explicitly setting the number of tests - $pack = $self->exported_to || return; - } +=item * Setting 'no_plan' - no strict 'refs'; ## no critic - no warnings 'once'; - my $old_value = ${$pack . '::TODO'}; - $set and ${$pack . '::TODO'} = $new_value; - return $old_value; -} +=item * Set 'skip_all'. -sub todo { - my ($self, $pack) = @_; +=back - return $self->{Todo} if defined $self->{Todo}; +This is currently used in subtests when we implicitly call C<< $Test->done_testing >> +if the developer has not set a plan. - my $ctx = $self->ctx; +=end _private - my $todo = $self->find_TODO($pack); - return $todo if defined $todo; +=cut - return ''; +sub _plan_handled { + my $self = shift; + return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; } -sub in_todo { - my $self = shift; - my $ctx = $self->ctx; - return 1 if $ctx->in_todo; +=item B - return (defined $self->{Todo} || $self->find_TODO) ? 1 : 0; -} + my $ok = $child->finalize; -sub todo_start { - my $self = shift; - my $message = @_ ? shift : ''; +When your child is done running tests, you must call C to clean up +and tell the parent your pass/fail status. - $self->{Start_Todo}++; - if ($self->in_todo) { - push @{$self->{Todo_Stack}} => $self->todo; - } - $self->{Todo} = $message; +Calling C on a child with open children will C. - return; -} +If the child falls out of scope before C is called, a failure +diagnostic will be issued and the child is considered to have failed. -sub todo_end { +No attempt to call methods on a child after C is called is +guaranteed to succeed. + +Calling this on the root builder is a no-op. + +=cut + +sub finalize { my $self = shift; - if (!$self->{Start_Todo}) { - $self->ctx(-1)->throw('todo_end() called without todo_start()'); + return unless $self->parent; + if( $self->{Child_Name} ) { + $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); } - $self->{Start_Todo}--; + local $? = 0; # don't fail if $subtests happened to set $? nonzero + $self->_ending; - if ($self->{Start_Todo} && @{$self->{Todo_Stack}}) { - $self->{Todo} = pop @{$self->{Todo_Stack}}; - } - else { - delete $self->{Todo}; + # XXX This will only be necessary for TAP envelopes (we think) + #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $ok = 1; + $self->parent->{Child_Name} = undef; + unless ($self->{Bailed_Out}) { + if ( $self->{Skip_All} ) { + $self->parent->skip($self->{Skip_All}, $self->name); + } + elsif ( not @{ $self->{Test_Results} } ) { + $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); + } + else { + $self->parent->ok( $self->is_passing, $self->name ); + } } + $? = $self->{Child_Error}; + delete $self->{Parent}; - return; + return $self->is_passing; } -##################################### -# }}} Finding Testers and Providers # -##################################### - -################ -# {{{ Planning # -################ - -my %PLAN_CMDS = ( - no_plan => 'no_plan', - skip_all => 'skip_all', - tests => '_plan_tests', -); +sub _indent { + my $self = shift; -sub plan { - my ($self, $cmd, @args) = @_; + if( @_ ) { + $self->{Indent} = shift; + } - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); - WARN_OF_OVERRIDE(plan => $ctx); + return $self->{Indent}; +} - return unless $cmd; +=item B - if (my $method = $PLAN_CMDS{$cmd}) { - $self->$method(@args); - } - else { - my @in = grep { defined } ($cmd, @args); - $self->ctx->throw("plan() doesn't understand @in"); - } + if ( my $parent = $builder->parent ) { + ... + } - return 1; -} +Returns the parent C instance, if any. Only used with child +builders for nested TAP. -sub skip_all { - my ($self, $reason) = @_; +=cut - $self->{Skip_All} = 1; +sub parent { shift->{Parent} } - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); +=item B - $ctx->_plan(0, 'SKIP', $reason); -} + diag $builder->name; -sub no_plan { - my ($self, @args) = @_; +Returns the name of the current builder. Top level builders default to C<$0> +(the name of the executable). Child builders are named via the C +method. If no name is supplied, will be named "Child of $parent->name". - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); +=cut - $ctx->alert("no_plan takes no arguments") if @args; - $ctx->_plan(0, 'NO PLAN'); +sub name { shift->{Name} } - return 1; +sub DESTROY { + my $self = shift; + if ( $self->parent and $$ == $self->{Original_Pid} ) { + my $name = $self->name; + $self->diag(<<"FAIL"); +Child ($name) exited without calling finalize() +FAIL + $self->parent->{In_Destroy} = 1; + $self->parent->ok(0, $name); + } } -sub _plan_tests { - my ($self, $arg) = @_; +=item B - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); + $Test->reset; - if ($arg) { - $ctx->throw("Number of tests must be a positive integer. You gave it '$arg'") - unless $arg =~ /^\+?\d+$/; +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. - $ctx->_plan($arg); - } - elsif (!defined $arg) { - $ctx->throw("Got an undefined number of tests"); - } - else { - $ctx->throw("You said to run 0 tests"); - } +=cut - return; -} +our $Level; -sub done_testing { - my ($self, $num_tests) = @_; +sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my($self) = @_; - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); - WARN_OF_OVERRIDE(done_testing => $ctx); + # 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; - my $out = $ctx->stream->done_testing($ctx, $num_tests); - return $out; -} + $self->{Name} = $0; + $self->is_passing(1); + $self->{Ending} = 0; + $self->{Have_Plan} = 0; + $self->{No_Plan} = 0; + $self->{Have_Output_Plan} = 0; + $self->{Done_Testing} = 0; -################ -# }}} Planning # -################ + $self->{Original_Pid} = $$; + $self->{Child_Name} = undef; + $self->{Indent} ||= ''; -############################# -# {{{ Base Event Producers # -############################# + $self->{Curr_Test} = 0; + $self->{Test_Results} = &share( [] ); -sub ok { - my $self = shift; - my($test, $name) = @_; + $self->{Exported_To} = undef; + $self->{Expected_Tests} = 0; - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); - WARN_OF_OVERRIDE(ok => $ctx); + $self->{Skip_All} = 0; - if ($self->{child}) { - $self->is_passing(0); - $ctx->throw("Cannot run test ($name) with active children"); - } + $self->{Use_Nums} = 1; - $ctx->_unwind_ok($test, $name); - return $test ? 1 : 0; -} + $self->{No_Header} = 0; + $self->{No_Ending} = 0; -sub BAIL_OUT { - my( $self, $reason ) = @_; - $self->ctx()->bail($reason); -} + $self->{Todo} = undef; + $self->{Todo_Stack} = []; + $self->{Start_Todo} = 0; + $self->{Opened_Testhandles} = 0; -sub skip { - my( $self, $why ) = @_; - $why ||= ''; - unoverload_str( \$why ); + $self->_share_keys; + $self->_dup_stdhandles; - my $ctx = $self->ctx(); - $ctx->set_skip($why); - $ctx->ok(1, ''); - $ctx->set_skip(undef); + return; } -sub todo_skip { - my( $self, $why ) = @_; - $why ||= ''; - unoverload_str( \$why ); - - my $ctx = $self->ctx(); - $ctx->set_skip($why); - $ctx->set_todo($why); - $ctx->ok(0, ''); - $ctx->set_skip(undef); - $ctx->set_todo(undef); -} -sub diag { +# Shared scalar values are lost when a hash is copied, so we have +# a separate method to restore them. +# Shared references are retained across copies. +sub _share_keys { my $self = shift; - my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); - WARN_OF_OVERRIDE(diag => $ctx); + share( $self->{Curr_Test} ); - $ctx->_diag($msg); return; } -sub note { - my $self = shift; - my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; - my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx(); - WARN_OF_OVERRIDE(note => $ctx); +=back - $ctx->_note($msg); -} +=head2 Setting up tests -############################# -# }}} Base Event Producers # -############################# +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. -####################### -# {{{ Public helpers # -####################### +=over 4 -sub explain { - my $self = shift; +=item B - return map { - ref $_ - ? do { - protect { require Data::Dumper }; - my $dumper = Data::Dumper->new( [$_] ); - $dumper->Indent(1)->Terse(1); - $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); - $dumper->Dump; - } - : $_ - } @_; -} + $Test->plan('no_plan'); + $Test->plan( skip_all => $reason ); + $Test->plan( tests => $num_tests ); -sub carp { - my $self = shift; - $self->ctx->alert(join '' => @_); -} +A convenient way to set up your tests. Call this and Test::Builder +will print the appropriate headers and take the appropriate actions. -sub croak { - my $self = shift; - $self->ctx->throw(join '' => @_); -} +If you call C, don't call any of the other methods below. -sub has_plan { - my $self = shift; +If a child calls "skip_all" in the plan, a C is +thrown. Trap this error, call C and don't run any more tests on +the child. - my $plan = $self->ctx->stream->plan || return undef; - return 'no_plan' if $plan->directive && $plan->directive eq 'NO PLAN'; - return $plan->max; -} + my $child = $Test->child('some child'); + eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) }; + if ( eval { $@->isa('Test::Builder::Exception') } ) { + $child->finalize; + return; + } + # run your tests -sub reset { - my $self = shift; - my %params = @_; +=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->{use_shared} = 1 if $params{shared_stream}; + $self->croak("You tried to plan twice") if $self->{Have_Plan}; - if ($self->{use_shared}) { - Test::Stream->shared->_reset; - Test::Stream->shared->state->[-1]->[STATE_LEGACY] = []; + if( my $method = $plan_cmds{$cmd} ) { + local $Level = $Level + 1; + $self->$method($arg); } else { - $self->{stream} = Test::Stream->new(); - $self->{stream}->set_use_legacy(1); - $self->{stream}->state->[-1]->[STATE_LEGACY] = []; + my @args = grep { defined } ( $cmd, $arg ); + $self->croak("plan() doesn't understand @args"); } - # 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->{Name} = $0; + return 1; +} - $self->{Original_Pid} = $$; - $self->{Child_Name} = undef; - $self->{Exported_To} = undef; +sub _plan_tests { + my($self, $arg) = @_; - $self->{Todo} = undef; - $self->{Todo_Stack} = []; - $self->{Start_Todo} = 0; - $self->{Opened_Testhandles} = 0; + 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; } -####################### -# }}} Public helpers # -####################### +=item B -################################# -# {{{ Advanced Event Producers # -################################# + my $max = $Test->expected_tests; + $Test->expected_tests($max); -sub cmp_ok { - my( $self, $got, $type, $expect, $name ) = @_; - my $ctx = $self->ctx; - my ($ok, @diag) = tmt->cmp_check($got, $type, $expect); - $ctx->ok($ok, $name, \@diag); - return $ok; -} +Gets/sets the number of tests we expect this test to run and prints out +the appropriate headers. -sub is_eq { - my( $self, $got, $expect, $name ) = @_; - my $ctx = $self->ctx; - my ($ok, @diag) = tmt->is_eq($got, $expect); - $ctx->ok($ok, $name, \@diag); - return $ok; -} +=cut -sub is_num { - my( $self, $got, $expect, $name ) = @_; - my $ctx = $self->ctx; - my ($ok, @diag) = tmt->is_num($got, $expect); - $ctx->ok($ok, $name, \@diag); - return $ok; -} +sub expected_tests { + my $self = shift; + my($max) = @_; -sub isnt_eq { - my( $self, $got, $dont_expect, $name ) = @_; - my $ctx = $self->ctx; - my ($ok, @diag) = tmt->isnt_eq($got, $dont_expect); - $ctx->ok($ok, $name, \@diag); - return $ok; -} + if(@_) { + $self->croak("Number of tests must be a positive integer. You gave it '$max'") + unless $max =~ /^\+?\d+$/; -sub isnt_num { - my( $self, $got, $dont_expect, $name ) = @_; - my $ctx = $self->ctx; - my ($ok, @diag) = tmt->isnt_num($got, $dont_expect); - $ctx->ok($ok, $name, \@diag); - return $ok; -} + $self->{Expected_Tests} = $max; + $self->{Have_Plan} = 1; -sub like { - my( $self, $thing, $regex, $name ) = @_; - my $ctx = $self->ctx; - my ($ok, @diag) = tmt->regex_check($thing, $regex, '=~'); - $ctx->ok($ok, $name, \@diag); - return $ok; + $self->_output_plan($max) unless $self->no_header; + } + return $self->{Expected_Tests}; } -sub unlike { - my( $self, $thing, $regex, $name ) = @_; - my $ctx = $self->ctx; - my ($ok, @diag) = tmt->regex_check($thing, $regex, '!~'); - $ctx->ok($ok, $name, \@diag); - return $ok; -} +=item B -################################# -# }}} Advanced Event Producers # -################################# + $Test->no_plan; -################################################ -# {{{ Misc # -################################################ +Declares that this test will run an indeterminate number of tests. -sub _new_fh { - my $self = shift; - my($file_or_fh) = shift; +=cut - return $file_or_fh if $self->is_fh($file_or_fh); +sub no_plan { + my($self, $arg) = @_; - my $fh; - if( ref $file_or_fh eq 'SCALAR' ) { - open $fh, ">>", $file_or_fh - or croak("Can't open scalar ref $file_or_fh: $!"); - } - else { - open $fh, ">", $file_or_fh - or croak("Can't open test output log $file_or_fh: $!"); - Test::Stream::IOSets->_autoflush($fh); + $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 + + $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 was declared, +this will override. + +If C 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 is, in effect, used when you'd want to use C, 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(scalar @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; + + # The wrong number of tests were run + $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; + + # No tests were run + $self->is_passing(0) if $self->{Curr_Test} == 0; + + return 1; +} + + +=item B + + $plan = $Test->has_plan + +Find out whether a plan has been defined. C<$plan> is either C (no plan +has been set), C (indeterminate # of tests) or an integer (the number +of expected tests). + +=cut + +sub has_plan { + my $self = shift; + + return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; + return('no_plan') if $self->{No_Plan}; + return(undef); +} + +=item B + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given C<$reason>. Exits immediately with 0. + +=cut + +sub skip_all { + my( $self, $reason ) = @_; + + $self->{Skip_All} = $self->parent ? $reason : 1; + + $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; + if ( $self->parent ) { + die bless {} => 'Test::Builder::Exception'; + } + exit(0); +} + +=item B + + 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 + + $Test->ok($test, $name); + +Your basic test. Pass if C<$test> is true, fail if $test is false. Just +like Test::Simple's C. + +=cut + +sub ok { + my( $self, $test, $name ) = @_; + + if ( $self->{Child_Name} and not $self->{In_Destroy} ) { + $name = 'unnamed test' unless defined $name; + $self->is_passing(0); + $self->croak("Cannot run test ($name) with active children"); + } + # $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]); + } + } + + $self->is_passing(0) unless $test || $self->in_todo; + + # Check that we haven't violated the plan + $self->_check_is_passing_plan(); + + return $test ? 1 : 0; +} + + +# Check that we haven't yet violated the plan and set +# is_passing() accordingly +sub _check_is_passing_plan { + my $self = shift; + + my $plan = $self->has_plan; + return unless defined $plan; # no plan yet defined + return unless $plan !~ /\D/; # no numeric plan + $self->is_passing(0) if $plan < $self->{Curr_Test}; +} + + +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 + + $Test->is_eq($got, $expected, $name); + +Like Test::More's C. Checks if C<$got eq $expected>. This is the +string version. + +C only ever matches another C. + +=item B + + $Test->is_num($got, $expected, $name); + +Like Test::More's C. Checks if C<$got == $expected>. This is the +numeric version. + +C only ever matches another C. + +=cut + +sub is_eq { + my( $self, $got, $expect, $name ) = @_; + local $Level = $Level + 1; + + 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; + + 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 + + $Test->isnt_eq($got, $dont_expect, $name); + +Like L's C. Checks if C<$got ne $dont_expect>. This is +the string version. + +=item B + + $Test->isnt_num($got, $dont_expect, $name); + +Like L's C. 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 + + $Test->like($thing, qr/$regex/, $name); + $Test->like($thing, '/$regex/', $name); + +Like L's C. Checks if $thing matches the given C<$regex>. + +=item B + + $Test->unlike($thing, qr/$regex/, $name); + $Test->unlike($thing, '/$regex/', $name); + +Like L's C. Checks if $thing B the +given C<$regex>. + +=cut + +sub like { + my( $self, $thing, $regex, $name ) = @_; + + local $Level = $Level + 1; + return $self->_regex_ok( $thing, $regex, '=~', $name ); +} + +sub unlike { + my( $self, $thing, $regex, $name ) = @_; + + local $Level = $Level + 1; + return $self->_regex_ok( $thing, $regex, '!~', $name ); +} + +=item B + + $Test->cmp_ok($thing, $type, $that, $name); + +Works just like L's C. + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=cut + +my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); + +# Bad, these are not comparison operators. Should we include more? +my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); + +sub cmp_ok { + my( $self, $got, $type, $expect, $name ) = @_; + + if ($cmp_ok_bl{$type}) { + $self->croak("$type is not a valid comparison operator in cmp_ok()"); + } + + my ($test, $succ); + my $error; + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + my($pack, $file, $line) = $self->caller(); + + # This is so that warnings come out at the caller's level + $succ = eval qq[ +#line $line "(eval in cmp_ok) $file" +\$test = (\$got $type \$expect); +1; +]; + $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") unless $succ; +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; +} - return $fh; +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 output { +sub _caller_context { my $self = shift; - my $handles = $self->ctx->stream->io_sets->init_encoding('legacy'); - $handles->[0] = $self->_new_fh(@_) if @_; - return $handles->[0]; + + my( $pack, $file, $line ) = $self->caller(1); + + my $code = ''; + $code .= "#line $line $file\n" if defined $file and defined $line; + + return $code; } -sub failure_output { - my $self = shift; - my $handles = $self->ctx->stream->io_sets->init_encoding('legacy'); - $handles->[1] = $self->_new_fh(@_) if @_; - return $handles->[1]; +=back + + +=head2 Other Testing Methods + +These are methods which are used in the course of writing a test but are not themselves tests. + +=over 4 + +=item B + + $Test->BAIL_OUT($reason); + +Indicates to the L 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; + + if ($self->parent) { + $self->{Bailed_Out_Reason} = $reason; + $self->no_ending(1); + die bless {} => 'Test::Builder::Exception'; + } + + $self->_print("Bail out! $reason"); + exit 255; } -sub todo_output { - my $self = shift; - my $handles = $self->ctx->stream->io_sets->init_encoding('legacy'); - $handles->[2] = $self->_new_fh(@_) if @_; - return $handles->[2] || $handles->[0]; +=for deprecated +BAIL_OUT() used to be BAILOUT() + +=cut + +{ + no warnings 'once'; + *BAILOUT = \&BAIL_OUT; } -sub reset_outputs { - my $self = shift; - my $ctx = $self->ctx; - $ctx->stream->io_sets->reset_legacy; +=item B + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting C<$why>. + +=cut + +sub skip { + my( $self, $why, $name ) = @_; + $why ||= ''; + $name = '' unless defined $name; + $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 => $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; } -sub use_numbers { - my $self = shift; - my $ctx = $self->ctx; - $ctx->stream->set_use_numbers(@_) if @_; - $ctx->stream->use_numbers; +=item B + + $Test->todo_skip; + $Test->todo_skip($why); + +Like C, 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; } -sub no_ending { - my $self = shift; - my $ctx = $self->ctx; - $ctx->stream->set_no_ending(@_) if @_; - $ctx->stream->no_ending || 0; +=begin _unimplemented + +=item B + + $Test->skip_rest; + $Test->skip_rest($reason); + +Like C, only it skips all the rest of the tests you plan to run +and terminates the test. + +If you're running under C, it skips once and terminates the +test. + +=end _unimplemented + +=back + + +=head2 Test building utility methods + +These methods are useful when writing your own test methods. + +=over 4 + +=item B + + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); + +This method used to be useful back when Test::Builder worked on Perls +before 5.6 which didn't have qr//. Now its pretty useless. + +Convenience method for building testing functions that take regular +expressions as arguments. + +Takes a quoted regular expression produced by C, or a string +representing a regular expression. + +Returns a Perl value which may be used instead of the corresponding +regular expression, or C if its argument is not recognised. + +For example, a version of C, sans the useful diagnostic messages, +could be written as: + + sub laconic_like { + my ($self, $thing, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($thing =~ 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 no_header { - my $self = shift; - my $ctx = $self->ctx; - $ctx->stream->set_no_header(@_) if @_; - $ctx->stream->no_header || 0; +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 no_diag { - my $self = shift; - my $ctx = $self->ctx; - $ctx->stream->set_no_diag(@_) if @_; - $ctx->stream->no_diag || 0; +sub _regex_ok { + my( $self, $thing, $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; + } + + { + my $test; + my $context = $self->_caller_context; + + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + # No point in issuing an uninit warning, they'll see it in the diagnostics + no warnings 'uninitialized'; + + $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; + } + + $test = !$test if $cmp eq '!~'; + + local $Level = $Level + 1; + $ok = $self->ok( $test, $name ); + } + + unless($ok) { + $thing = defined $thing ? "'$thing'" : 'undef'; + my $match = $cmp eq '=~' ? "doesn't match" : "matches"; + + local $Level = $Level + 1; + $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); + %s + %13s '%s' +DIAGNOSTIC + + } + + return $ok; } -sub exported_to { - my($self, $pack) = @_; - $self->{Exported_To} = $pack if defined $pack; - return $self->{Exported_To}; +# 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 + + 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; @@ -716,628 +1552,1121 @@ sub is_fh { return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob - my $out; - protect { - $out = eval { $maybe_fh->isa("IO::Handle") } - || eval { tied($maybe_fh)->can('TIEHANDLE') }; + return eval { $maybe_fh->isa("IO::Handle") } || + eval { tied($maybe_fh)->can('TIEHANDLE') }; +} + +=back + + +=head2 Test style + + +=over 4 + +=item B + + $Test->level($how_high); + +How far up the call stack should 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 + + $Test->use_numbers($on_or_off); + +Whether or not the test should output numbers. That is, this if true: + + ok 1 + ok 2 + ok 3 + +or this if false + + ok + ok + ok + +Most useful when you can't depend on the test output order, such as +when threads or forking is involved. + +Defaults to on. + +=cut + +sub use_numbers { + my( $self, $use_nums ) = @_; + + if( defined $use_nums ) { + $self->{Use_Nums} = $use_nums; + } + return $self->{Use_Nums}; +} + +=item B + + $Test->no_diag($no_diag); + +If set true no diagnostics will be printed. This includes calls to +C. + +=item B + + $Test->no_ending($no_ending); + +Normally, Test::Builder does some extra diagnostics when the test +ends. It also changes the exit code as described below. + +If this is true, none of that will be done. + +=item B + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + +=cut + +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}; }; - return $out; + no strict 'refs'; ## no critic + *{ __PACKAGE__ . '::' . $method } = $code; } -sub BAILOUT { goto &BAIL_OUT } +=back + +=head2 Output -sub expected_tests { +Controlling where the test output goes. + +It's ok for your test to change where STDOUT and STDERR point to, +Test::Builder's default output settings will not be affected. + +=over 4 + +=item B + + $Test->diag(@msgs); + +Prints out the given C<@msgs>. Like C, arguments are simply +appended together. + +Normally, it uses the C handle, but if this is for a +TODO test, the C 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 is often used in conjunction with +a failing test (C) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler + +=cut + +sub diag { + my $self = shift; + + $self->_print_comment( $self->_diag_fh, @_ ); +} + +=item B + + $Test->note(@msgs); + +Like C, but it prints to the C 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 + + 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; - my $ctx = $self->ctx; - $ctx->plan(@_) if @_; + return map { + ref $_ + ? do { + $self->_try(sub { require Data::Dumper }, die_on_fail => 1); - my $plan = $ctx->stream->state->[-1]->[STATE_PLAN] || return 0; - return $plan->max || 0; + my $dumper = Data::Dumper->new( [$_] ); + $dumper->Indent(1)->Terse(1); + $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); + $dumper->Dump; + } + : $_ + } @_; } -sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my $self = shift; +=begin _private - my $ctx = $self->ctx; +=item B<_print> - return wantarray ? $ctx->call : $ctx->package; -} + $Test->_print(@msgs); -sub level { - my( $self, $level ) = @_; - $Level = $level if defined $level; - return $Level; -} +Prints to the C filehandle. -sub maybe_regex { - my ($self, $regex) = @_; - return is_regex($regex); -} +=end _private -sub is_passing { +=cut + +sub _print { my $self = shift; - my $ctx = $self->ctx; - $ctx->stream->is_passing(@_); + return $self->_print_to_fh( $self->output, @_ ); } -# Yeah, this is not efficient, but it is only legacy support, barely anything -# uses it, and they really should not. -sub current_test { - my $self = shift; +sub _print_to_fh { + my( $self, $fh, @msgs ) = @_; - my $ctx = $self->ctx; - - if (@_) { - my ($num) = @_; - my $state = $ctx->stream->state->[-1]; - $state->[STATE_COUNT] = $num; - - my $old = $state->[STATE_LEGACY] || []; - my $new = []; - - my $nctx = $ctx->snapshot; - $nctx->set_todo('incrementing test number'); - $nctx->set_in_todo(1); - - for (1 .. $num) { - my $i; - $i = shift @$old while @$old && (!$i || !$i->isa('Test::Stream::Event::Ok')); - $i ||= Test::Stream::Event::Ok->new( - $nctx, - [CORE::caller()], - 0, - undef, - undef, - undef, - 1, - ); - - push @$new => $i; - } + # Prevent printing headers when only compiling. Mostly for when + # tests are deparsed with B::Deparse + return if $^C; - $state->[STATE_LEGACY] = $new; - } + my $msg = join '', @msgs; + my $indent = $self->_indent; - $ctx->stream->count; -} + local( $\, $", $, ) = ( undef, ' ', '' ); -sub details { - my $self = shift; - my $ctx = $self->ctx; - my $state = $ctx->stream->state->[-1]; - my @out; - return @out unless $state->[STATE_LEGACY]; + # Escape each line after the first with a # so we don't + # confuse Test::Harness. + $msg =~ s{\n(?!\z)}{\n$indent# }sg; - for my $e (@{$state->[STATE_LEGACY]}) { - next unless $e && $e->isa('Test::Stream::Event::Ok'); - push @out => $e->to_legacy; - } + # Stick a newline on the end if it needs it. + $msg .= "\n" unless $msg =~ /\n\z/; - return @out; + return print $fh $indent, $msg; } -sub summary { - my $self = shift; - my $ctx = $self->ctx; - my $state = $ctx->stream->state->[-1]; - return @{[]} unless $state->[STATE_LEGACY]; - return map { $_->isa('Test::Stream::Event::Ok') ? ($_->bool ? 1 : 0) : ()} @{$state->[STATE_LEGACY]}; -} +=item B -################################### -# }}} Misc # -################################### +=item B -#################### -# {{{ TB1.5 stuff # -#################### +=item B -# This is just a list of method Test::Builder current does not have that Test::Builder 1.5 does. -my %TB15_METHODS = map { $_ => 1 } qw{ - _file_and_line _join_message _make_default _my_exit _reset_todo_state - _result_to_hash _results _todo_state formatter history in_test - no_change_exit_code post_event post_result set_formatter set_plan test_end - test_exit_code test_start test_state -}; + my $filehandle = $Test->output; + $Test->output($filehandle); + $Test->output($filename); + $Test->output(\$scalar); -our $AUTOLOAD; +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>. -sub AUTOLOAD { - $AUTOLOAD =~ m/^(.*)::([^:]+)$/; - my ($package, $sub) = ($1, $2); +B is where normal "ok/not ok" test output goes. - my @caller = CORE::caller(); - my $msg = qq{Can't locate object method "$sub" via package "$package" at $caller[1] line $caller[2].\n}; +Defaults to STDOUT. - $msg .= <<" EOT" if $TB15_METHODS{$sub}; +B is where diagnostic output on test failures and +C goes. It is normally not read by Test::Harness and instead is +displayed to the user. - ************************************************************************* - '$sub' is a Test::Builder 1.5 method. Test::Builder 1.5 is a dead branch. - You need to update your code so that it no longer treats Test::Builders - over a specific version number as anything special. +Defaults to STDERR. - See: http://blogs.perl.org/users/chad_exodist_granum/2014/03/testmore---new-maintainer-also-stop-version-checking.html - ************************************************************************* - EOT +C is used instead of C for the +diagnostics of a failing TODO test. These will not be seen by the +user. - die $msg; -} +Defaults to STDOUT. -#################### -# }}} TB1.5 stuff # -#################### +=cut -################################## -# {{{ Legacy support, do not use # -################################## +sub output { + my( $self, $fh ) = @_; -# These are here to support old versions of Test::More which may be bundled -# with some dists. See https://github.com/Test-More/test-more/issues/479 + if( defined $fh ) { + $self->{Out_FH} = $self->_new_fh($fh); + } + return $self->{Out_FH}; +} -sub _try { - my( $self, $code, %opts ) = @_; +sub failure_output { + my( $self, $fh ) = @_; - my $error; - my $return; - protect { - $return = eval { $code->() }; - $error = $@; - }; + if( defined $fh ) { + $self->{Fail_FH} = $self->_new_fh($fh); + } + return $self->{Fail_FH}; +} - die $error if $error and $opts{die_on_fail}; +sub todo_output { + my( $self, $fh ) = @_; - return wantarray ? ( $return, $error ) : $return; + if( defined $fh ) { + $self->{Todo_FH} = $self->_new_fh($fh); + } + return $self->{Todo_FH}; } -sub _unoverload { +sub _new_fh { my $self = shift; - my $type = shift; - - $self->_try(sub { require overload; }, die_on_fail => 1); + my($file_or_fh) = shift; - foreach my $thing (@_) { - if( $self->_is_object($$thing) ) { - if( my $string_meth = overload::Method( $$thing, $type ) ) { - $$thing = $$thing->$string_meth(); - } + 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; + return $fh; } -sub _is_object { - my( $self, $thing ) = @_; +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; - return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; + return; } -sub _unoverload_str { +my( $Testout, $Testerr ); + +sub _dup_stdhandles { my $self = shift; - return $self->_unoverload( q[""], @_ ); + $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 _unoverload_num { +sub _open_testhandles { my $self = shift; - $self->_unoverload( '0+', @_ ); + return if $self->{Opened_Testhandles}; - for my $val (@_) { - next unless $self->_is_dualvar($$val); - $$val = $$val + 0; - } + # 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; } -# This is a hack to detect a dualvar such as $! -sub _is_dualvar { - my( $self, $val ) = @_; +sub _copy_io_layers { + my( $self, $src, $dst ) = @_; - # Objects are not dualvars. - return 0 if ref $val; + $self->_try( + sub { + require PerlIO; + my @src_layers = PerlIO::get_layers($src); - no warnings 'numeric'; - my $numval = $val + 0; - return ($numval != 0 and $numval ne $val ? 1 : 0); + _apply_layers($dst, @src_layers) if @src_layers; + } + ); + + return; } -################################## -# }}} Legacy support, do not use # -################################## +sub _apply_layers { + my ($fh, @layers) = @_; + my %seen; + my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; + binmode($fh, join(":", "", "raw", @unique)); +} -1; -__END__ +=item reset_outputs -=pod + $tb->reset_outputs; -=encoding UTF-8 +Resets all the output filehandles back to their defaults. -=head1 NAME +=cut + +sub reset_outputs { + my $self = shift; -Test::Builder - *DEPRECATED* Module for building testing libraries. + $self->output ($Testout); + $self->failure_output($Testerr); + $self->todo_output ($Testout); -=head1 DESCRIPTION + return; +} -This module was previously the base module for almost any testing library. This -module is now little more than a compatability wrapper around L. -If you are looking to write or update a testing library you should look at -L. +=item carp -=head1 PACKAGE VARS + $tb->carp(@message); -=over 4 +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); -=item $Test::Builder::Test +Dies with C<@message> but the message will appear to come from the +point where the original test function was called (C<< $tb->caller >>). -The variable that holds the Test::Builder singleton. +=cut -=item $Test::Builder::Level +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(@_); +} -In the past this variable was used to track stack depth so that Test::Builder -could report the correct line number. If you use Test::Builder this will still -work, but in new code it is better to use the L module. =back -=head1 METHODS -=head2 CONSTRUCTORS +=head2 Test Status and Info =over 4 -=item Test::Builder->new +=item B -Returns the singleton stored in C<$Test::Builder::Test>. + my $curr_test = $Test->current_test; + $Test->current_test($num); -=item Test::Builder->create +Gets/sets the current test number we're on. You usually shouldn't +have to set this. -=item Test::Builder->create(use_shared => 1) +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. -Returns a new instance of Test::Builder. It is important to note that this -instance will not use the shared L object unless you pass in the -C<< use_shared => 1 >> argument. +=cut -=back +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}; +} -=head2 UTIL +=item B -=over 4 + my $ok = $builder->is_passing; -=item $TB->ctx +Indicates if the test suite is currently passing. -Helper method for Test::Builder to get a L object. +More formally, it will be false if anything has happened which makes +it impossible for the test suite to pass. True otherwise. -=item $TB->depth +For example, if no tests have run C will be true because +even though a suite with no tests is a failure you can add a passing +test to it and start passing. -Get the subtest depth +Don't think about it too much. -=item $TB->find_TODO +=cut -=item $TB->in_todo +sub is_passing { + my $self = shift; -=item $TB->todo + if( @_ ) { + $self->{Is_Passing} = shift; + } -These all check on todo state and value + return $self->{Is_Passing}; +} -=back -=head2 OTHER +=item B -=over 4 + my @tests = $Test->summary; -=item $TB->caller +A simple summary of the tests so far. True for pass, false for fail. +This is a logical pass/fail, so todos are passes. -=item $TB->carp +Of course, test #1 is $tests[0], etc... -=item $TB->croak +=cut -These let you figure out when/where the test is defined in the test file. +sub summary { + my($self) = shift; -=item $TB->child + return map { $_->{'ok'} } @{ $self->{Test_Results} }; +} -Start a subtest (Please do not use this) +=item B
-=item $TB->finalize + my @tests = $Test->details; -Finish a subtest (Please do not use this) +Like C, but with a lot more detail. -=item $TB->explain + $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) + }; -Interface to Data::Dumper that dumps whatever you give it. +'ok' is true if Test::Harness will consider the test to be a pass. -=item $TB->exported_to +'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. -This used to tell you what package used Test::Builder, it never worked well. -The previous bad and unpredictable behavior of this has largely been preserved, -however nothing internal uses it in any meaningful way anymore. +'name' is the name of the test. -=item $TB->is_fh +'type' indicates if it was a special test. Normal tests have a type +of ''. Type can be one of the following: -Check if something is a filehandle + skip see skip() + todo see todo() + todo_skip see todo_skip() + unknown see below -=item $TB->level +Sometimes the Test::Builder test counter is incremented without it +printing any test output, for example, when C 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. -Get/Set C<$Test::Builder::Level>. $Level is a package var, and most things -localize it, so this method is pretty useless. +For example "not ok 23 - hole count # TODO insufficient donuts" would +result in this structure: -=item $TB->maybe_regex + $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' + }; -Check if something might be a regex. +=cut -=item $TB->reset +sub details { + my $self = shift; + return @{ $self->{Test_Results} }; +} -Reset the builder object to a very basic and default state. You almost -certainly do not need this unless you are writing a tool to test testing -libraries. Even then you probably do not want this. +=item B -=item $TB->todo_end + my $todo_reason = $Test->todo; + my $todo_reason = $Test->todo($pack); -=item $TB->todo_start +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. -Start/end TODO state, there are better ways to do this now. +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. -=back +C 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 is usually called inside +a test function. As a last resort it will use C. -=head2 STREAM INTERFACE +Sometimes there is some confusion about where C should be looking +for the C<$TODO> variable. If you want to be sure, tell it explicitly +what $pack to use. -These simply interface into functionality of L. +=cut -=over 4 +sub todo { + my( $self, $pack ) = @_; -=item $TB->failure_output + return $self->{Todo} if defined $self->{Todo}; -=item $TB->output + local $Level = $Level + 1; + my $todo = $self->find_TODO($pack); + return $todo if defined $todo; -=item $TB->reset_outputs + return ''; +} -=item $TB->todo_output +=item B -These get/set the IO handle used in the 'legacy' tap encoding. + my $todo_reason = $Test->find_TODO(); + my $todo_reason = $Test->find_TODO($pack); -=item $TB->no_diag +Like C but only returns the value of C<$TODO> ignoring +C. -Do not display L events. +Can also be used to set C<$TODO> to a new value while returning the +old value: -=item $TB->no_ending + my $old_reason = $Test->find_TODO($pack, 1, $new_reason); -Do not do some special magic at the end that tells you what went wrong with -tests. +=cut -=item $TB->no_header +sub find_TODO { + my( $self, $pack, $set, $new_value ) = @_; -Do not display the plan + $pack = $pack || $self->caller(1) || $self->exported_to; + return unless $pack; -=item $TB->use_numbers + no strict 'refs'; ## no critic + my $old_value = ${ $pack . '::TODO' }; + $set and ${ $pack . '::TODO' } = $new_value; + return $old_value; +} -Turn numbers in TAP on and off. +=item B -=back + my $in_todo = $Test->in_todo; -=head2 HISTORY +Returns true if the test is currently inside a TODO block. -=over +=cut -=item $TB->details +sub in_todo { + my $self = shift; -Get all the events that occured on this object. Each event will be transformed -into a hash that matches the legacy output of this method. + local $Level = $Level + 1; + return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; +} -=item $TB->expected_tests +=item B -Set/Get expected number of tests + $Test->todo_start(); + $Test->todo_start($message); -=item $TB->has_plan +This method allows you declare all subsequent tests as TODO tests, up until +the C method has been called. -Check if there is a plan +The C 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). -=item $TB->summary +Note that you can use this to nest "todo" tests -List of pass/fail results. + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; -=back +This is generally not recommended, but large testing systems often have weird +internal needs. -=head2 EVENT GENERATORS +We've tried to make this also work with the TODO: syntax, but it's not +guaranteed and its use is also discouraged: -See L, L, and -L. Calling the methods below is not advised. + 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; + } -=over 4 +Pick one style or another of "TODO" to be on the safe side. -=item $TB->BAILOUT +=cut -=item $TB->BAIL_OUT +sub todo_start { + my $self = shift; + my $message = @_ ? shift : ''; -=item $TB->cmp_ok + $self->{Start_Todo}++; + if( $self->in_todo ) { + push @{ $self->{Todo_Stack} } => $self->todo; + } + $self->{Todo} = $message; -=item $TB->current_test + return; +} -=item $TB->diag +=item C -=item $TB->done_testing + $Test->todo_end; -=item $TB->is_eq +Stops running tests as "TODO" tests. This method is fatal if called without a +preceding C method call. -=item $TB->is_num +=cut -=item $TB->is_passing +sub todo_end { + my $self = shift; -=item $TB->isnt_eq + if( !$self->{Start_Todo} ) { + $self->croak('todo_end() called without todo_start()'); + } -=item $TB->isnt_num + $self->{Start_Todo}--; -=item $TB->like + if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { + $self->{Todo} = pop @{ $self->{Todo_Stack} }; + } + else { + delete $self->{Todo}; + } -=item $TB->no_plan + return; +} -=item $TB->note +=item B -=item $TB->ok + my $package = $Test->caller; + my($pack, $file, $line) = $Test->caller; + my($pack, $file, $line) = $Test->caller($height); -=item $TB->plan +Like the normal C, except it reports according to your C. -=item $TB->skip +C<$height> will be added to the C. -=item $TB->skip_all +If C winds up off the top of the stack it report the highest context. -=item $TB->subtest +=cut -=item $TB->todo_skip +sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my( $self, $height ) = @_; + $height ||= 0; -=item $TB->unlike + my $level = $self->level + $height + 1; + my @caller; + do { + @caller = CORE::caller( $level ); + $level--; + } until @caller; + return wantarray ? @caller : $caller[0]; +} =back -=head2 ACCESSORS +=cut + +=begin _private =over 4 -=item $TB->stream +=item B<_sanity_check> + + $self->_sanity_check(); -Get the stream used by this builder (or the shared stream). +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. -=item $TB->name +=cut -Name of the test +#'# +sub _sanity_check { + my $self = shift; -=item $TB->parent + $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!' ); -Parent if this is a child. + return; +} -=back +=item B<_whoa> -=head1 MONKEYPATCHING + $self->_whoa($check, $description); -Many legacy testing modules monkeypatch C, C, and others. The -abillity to monkeypatch these to effect all events of the specified type is now -considered discouraged. For backwords compatability monkeypatching continues to -work, however in the distant future it will be removed. L upon -which Test::Builder is now built, provides hooks and API's for doing everything -that previously required monkeypatching. +A sanity check, similar to C. 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. -=head1 TUTORIALS +=cut -=over 4 +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 L +=item B<_my_exit> -The original L. Uses comedy to introduce you to testing from -scratch. + _my_exit($exit_num); -=item L +Perl seems to have some trouble with exiting inside an C block. +5.6.1 does some odd things. Instead, this function edits C<$?> +directly. It should B be called from inside an C block. +It doesn't actually exit, that's your job. -The L tutorial takes a more technical approach. -The idea behind this tutorial is to give you a technical introduction to -testing that can easily be used as a reference. This is for people who say -"Just tell me how to do it, and quickly!". +=cut -=item L +sub _my_exit { + $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) -The L tutorial is an introduction to writing -testing tools that play nicely with other L and L -based tools. This is what you should look at if you want to write -Test::MyWidget. + return 1; +} =back -=head1 SOURCE +=end _private -The source code repository for Test::More can be found at -F. +=cut -=head1 MAINTAINER +sub _ending { + my $self = shift; + return if $self->no_ending; + return if $self->{Ending}++; -=over 4 + my $real_exit_code = $?; -=item Chad Granum Eexodist@cpan.orgE + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + if( $self->{Original_Pid} != $$ ) { + return; + } -=back + # Ran tests but never declared a plan or hit done_testing + if( !$self->{Have_Plan} and $self->{Curr_Test} ) { + $self->is_passing(0); + $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); + + if($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. +FAIL + $self->is_passing(0); + _my_exit($real_exit_code) && return; + } -=head1 AUTHORS + # But if the tests ran, handle exit code. + my $test_results = $self->{Test_Results}; + if(@$test_results) { + my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; + if ($num_failed > 0) { -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). + my $exit_code = $num_failed <= 254 ? $num_failed : 254; + _my_exit($exit_code) && return; + } + } + _my_exit(254) && return; + } -=over 4 + # Exit if plan() was never called. This is so "require Test::Simple" + # doesn't puke. + if( !$self->{Have_Plan} ) { + return; + } -=item Chad Granum Eexodist@cpan.orgE + # Don't do an ending if we bailed out. + if( $self->{Bailed_Out} ) { + $self->is_passing(0); + 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}; + } -=item Fergal Daly Efergal@esatclear.ie>E + # 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]; + } -=item Mark Fowler Emark@twoshortplanks.comE + my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; -=item Michael G Schwern Eschwern@pobox.comE + my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; -=item 唐鳳 + 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 + $self->is_passing(0); + } -=back + if($num_failed) { + my $num_tests = $self->{Curr_Test}; + my $s = $num_failed == 1 ? '' : 's'; -=head1 COPYRIGHT + my $qualifier = $num_extra == 0 ? '' : ' run'; -There has been a lot of code migration between modules, -here are all the original copyrights together: + $self->diag(<<"FAIL"); +Looks like you failed $num_failed test$s of $num_tests$qualifier. +FAIL + $self->is_passing(0); + } -=over 4 + if($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. +FAIL + $self->is_passing(0); + _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; + } -=item Test::Stream + _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 + $self->is_passing(0); + _my_exit($real_exit_code) && return; + } + else { + $self->diag("No tests run!\n"); + $self->is_passing(0); + _my_exit(255) && return; + } + + $self->is_passing(0); + $self->_whoa( 1, "We fell off the end of _ending()" ); +} -=item Test::Stream::Tester +END { + $Test->_ending if defined $Test; +} -Copyright 2014 Chad Granum Eexodist7@gmail.comE. +=head1 EXIT CODES -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. +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. -See F +So the exit codes are... -=item Test::Simple + 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) -=item Test::More +If you fail more than 254 tests, it will be reported as 254. -=item Test::Builder +=head1 THREADS -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. +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 they will all be effected. -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. +While versions earlier than 5.8.1 had threads they contain too many +bugs to support. -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. +Test::Builder is only thread-aware if threads.pm is loaded I +Test::Builder. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. +=head1 MEMORY -See F +An informative hash, accessible via C, 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. -=item Test::use::ok +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 C should anything go unexpected. -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. +Future versions of Test::Builder will have a way to turn history off. -This work is published from Taiwan. -L +=head1 EXAMPLES -=item Test::Tester +CPAN can provide the best examples. L, L, +L and L all use Test::Builder. -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. +=head1 SEE ALSO -Under the same license as Perl itself +L, L, L -See http://www.perl.com/perl/misc/Artistic.html +=head1 AUTHORS + +Original code by chromatic, maintained by Michael G Schwern +Eschwern@pobox.comE -=item Test::Builder::Tester +=head1 MAINTAINERS -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. +=over 4 -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. +=item Chad Granum Eexodist@cpan.orgE =back + +=head1 COPYRIGHT + +Copyright 2002-2008 by chromatic Echromatic@wgz.orgE and + Michael G Schwern Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + +1; + diff --git a/cpan/Test-Simple/lib/Test/Builder/IO/Scalar.pm b/cpan/Test-Simple/lib/Test/Builder/IO/Scalar.pm new file mode 100644 index 0000000000..54700c42cb --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/IO/Scalar.pm @@ -0,0 +1,658 @@ +package Test::Builder::IO::Scalar; + + +=head1 NAME + +Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder + +=head1 DESCRIPTION + +This is a copy of L which ships with L to +support scalar references as filehandles on Perl 5.6. Newer +versions of Perl simply use C's built in support. + +L can not have dependencies on other modules without +careful consideration, so its simply been copied into the distribution. + +=head1 COPYRIGHT and LICENSE + +This file came from the "IO-stringy" Perl5 toolkit. + +Copyright (c) 1996 by Eryq. All rights reserved. +Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=cut + +# This is copied code, I don't care. +##no critic + +use Carp; +use strict; +use vars qw($VERSION @ISA); +use IO::Handle; + +use 5.005; + +### The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.113"; + +### Inheritance: +@ISA = qw(IO::Handle); + +#============================== + +=head2 Construction + +=over 4 + +=cut + +#------------------------------ + +=item new [ARGS...] + +I +Return a new, unattached scalar handle. +If any arguments are given, they're sent to open(). + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless \do { local *FH }, $class; + tie *$self, $class, $self; + $self->open(@_); ### open on anonymous by default + $self; +} +sub DESTROY { + shift->close; +} + +#------------------------------ + +=item open [SCALARREF] + +I +Open the scalar handle on a new scalar, pointed to by SCALARREF. +If no SCALARREF is given, a "private" scalar is created to hold +the file data. + +Returns the self object on success, undefined on error. + +=cut + +sub open { + my ($self, $sref) = @_; + + ### Sanity: + defined($sref) or do {my $s = ''; $sref = \$s}; + (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; + + ### Setup: + *$self->{Pos} = 0; ### seek position + *$self->{SR} = $sref; ### scalar reference + $self; +} + +#------------------------------ + +=item opened + +I +Is the scalar handle opened on something? + +=cut + +sub opened { + *{shift()}->{SR}; +} + +#------------------------------ + +=item close + +I +Disassociate the scalar handle from its underlying scalar. +Done automatically on destroy. + +=cut + +sub close { + my $self = shift; + %{*$self} = (); + 1; +} + +=back + +=cut + + + +#============================== + +=head2 Input and output + +=over 4 + +=cut + + +#------------------------------ + +=item flush + +I +No-op, provided for OO compatibility. + +=cut + +sub flush { "0 but true" } + +#------------------------------ + +=item getc + +I +Return the next character, or undef if none remain. + +=cut + +sub getc { + my $self = shift; + + ### Return undef right away if at EOF; else, move pos forward: + return undef if $self->eof; + substr(${*$self->{SR}}, *$self->{Pos}++, 1); +} + +#------------------------------ + +=item getline + +I +Return the next line, or undef on end of string. +Can safely be called in an array context. +Currently, lines are delimited by "\n". + +=cut + +sub getline { + my $self = shift; + + ### Return undef right away if at EOF: + return undef if $self->eof; + + ### Get next line: + my $sr = *$self->{SR}; + my $i = *$self->{Pos}; ### Start matching at this point. + + ### Minimal impact implementation! + ### We do the fast fast thing (no regexps) if using the + ### classic input record separator. + + ### Case 1: $/ is undef: slurp all... + if (!defined($/)) { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + + ### Case 2: $/ is "\n": zoom zoom zoom... + elsif ($/ eq "\012") { + + ### Seek ahead for "\n"... yes, this really is faster than regexps. + my $len = length($$sr); + for (; $i < $len; ++$i) { + last if ord (substr ($$sr, $i, 1)) == 10; + } + + ### Extract the line: + my $line; + if ($i < $len) { ### We found a "\n": + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); + *$self->{Pos} = $i+1; ### Remember where we finished up. + } + else { ### No "\n"; slurp the remainder: + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); + *$self->{Pos} = $len; + } + return $line; + } + + ### Case 3: $/ is ref to int. Do fixed-size records. + ### (Thanks to Dominique Quatravaux.) + elsif (ref($/)) { + my $len = length($$sr); + my $i = ${$/} + 0; + my $line = substr ($$sr, *$self->{Pos}, $i); + *$self->{Pos} += $i; + *$self->{Pos} = $len if (*$self->{Pos} > $len); + return $line; + } + + ### Case 4: $/ is either "" (paragraphs) or something weird... + ### This is Graham's general-purpose stuff, which might be + ### a tad slower than Case 2 for typical data, because + ### of the regexps. + else { + pos($$sr) = $i; + + ### If in paragraph mode, skip leading lines (and update i!): + length($/) or + (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); + + ### If we see the separator in the buffer ahead... + if (length($/) + ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! + : $$sr =~ m,\n\n,g ### (a paragraph) + ) { + *$self->{Pos} = pos $$sr; + return substr($$sr, $i, *$self->{Pos}-$i); + } + ### Else if no separator remains, just slurp the rest: + else { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + } +} + +#------------------------------ + +=item getlines + +I +Get all remaining lines. +It will croak() if accidentally called in a scalar context. + +=cut + +sub getlines { + my $self = shift; + wantarray or croak("can't call getlines in scalar context!"); + my ($line, @lines); + push @lines, $line while (defined($line = $self->getline)); + @lines; +} + +#------------------------------ + +=item print ARGS... + +I +Print ARGS to the underlying scalar. + +B this continues to always cause a seek to the end +of the string, but if you perform seek()s and tell()s, it is +still safer to explicitly seek-to-end before subsequent print()s. + +=cut + +sub print { + my $self = shift; + *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); + 1; +} +sub _unsafe_print { + my $self = shift; + my $append = join('', @_) . $\; + ${*$self->{SR}} .= $append; + *$self->{Pos} += length($append); + 1; +} +sub _old_print { + my $self = shift; + ${*$self->{SR}} .= join('', @_) . $\; + *$self->{Pos} = length(${*$self->{SR}}); + 1; +} + + +#------------------------------ + +=item read BUF, NBYTES, [OFFSET] + +I +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub read { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); + $n = length($read); + *$self->{Pos} += $n; + ($off ? substr($_[1], $off) : $_[1]) = $read; + return $n; +} + +#------------------------------ + +=item write BUF, NBYTES, [OFFSET] + +I +Write some bytes to the scalar. + +=cut + +sub write { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $data = substr($_[1], $off, $n); + $n = length($data); + $self->print($data); + return $n; +} + +#------------------------------ + +=item sysread BUF, LEN, [OFFSET] + +I +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub sysread { + my $self = shift; + $self->read(@_); +} + +#------------------------------ + +=item syswrite BUF, NBYTES, [OFFSET] + +I +Write some bytes to the scalar. + +=cut + +sub syswrite { + my $self = shift; + $self->write(@_); +} + +=back + +=cut + + +#============================== + +=head2 Seeking/telling and other attributes + +=over 4 + +=cut + + +#------------------------------ + +=item autoflush + +I +No-op, provided for OO compatibility. + +=cut + +sub autoflush {} + +#------------------------------ + +=item binmode + +I +No-op, provided for OO compatibility. + +=cut + +sub binmode {} + +#------------------------------ + +=item clearerr + +I Clear the error and EOF flags. A no-op. + +=cut + +sub clearerr { 1 } + +#------------------------------ + +=item eof + +I Are we at end of file? + +=cut + +sub eof { + my $self = shift; + (*$self->{Pos} >= length(${*$self->{SR}})); +} + +#------------------------------ + +=item seek OFFSET, WHENCE + +I Seek to a given position in the stream. + +=cut + +sub seek { + my ($self, $pos, $whence) = @_; + my $eofpos = length(${*$self->{SR}}); + + ### Seek: + if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET + elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR + elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END + else { croak "bad seek whence ($whence)" } + + ### Fixup: + if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } + if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } + return 1; +} + +#------------------------------ + +=item sysseek OFFSET, WHENCE + +I Identical to C, I + +=cut + +sub sysseek { + my $self = shift; + $self->seek (@_); +} + +#------------------------------ + +=item tell + +I +Return the current position in the stream, as a numeric offset. + +=cut + +sub tell { *{shift()}->{Pos} } + +#------------------------------ + +=item use_RS [YESNO] + +I +B +Obey the current setting of $/, like IO::Handle does? +Default is false in 1.x, but cold-welded true in 2.x and later. + +=cut + +sub use_RS { + my ($self, $yesno) = @_; + carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; + } + +#------------------------------ + +=item setpos POS + +I +Set the current position, using the opaque value returned by C. + +=cut + +sub setpos { shift->seek($_[0],0) } + +#------------------------------ + +=item getpos + +I +Return the current position in the string, as an opaque object. + +=cut + +*getpos = \&tell; + + +#------------------------------ + +=item sref + +I +Return a reference to the underlying scalar. + +=cut + +sub sref { *{shift()}->{SR} } + + +#------------------------------ +# Tied handle methods... +#------------------------------ + +# Conventional tiehandle interface: +sub TIEHANDLE { + ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) + ? $_[1] + : shift->new(@_)); +} +sub GETC { shift->getc(@_) } +sub PRINT { shift->print(@_) } +sub PRINTF { shift->print(sprintf(shift, @_)) } +sub READ { shift->read(@_) } +sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } +sub WRITE { shift->write(@_); } +sub CLOSE { shift->close(@_); } +sub SEEK { shift->seek(@_); } +sub TELL { shift->tell(@_); } +sub EOF { shift->eof(@_); } + +#------------------------------------------------------------ + +1; + +__END__ + + + +=back + +=cut + + +=head1 WARNINGS + +Perl's TIEHANDLE spec was incomplete prior to 5.005_57; +it was missing support for C, C, and C. +Attempting to use these functions with an IO::Scalar will not work +prior to 5.005_57. IO::Scalar will not have the relevant methods +invoked; and even worse, this kind of bug can lie dormant for a while. +If you turn warnings on (via C<$^W> or C), +and you see something like this... + + attempt to seek on unopened filehandle + +...then you are probably trying to use one of these functions +on an IO::Scalar with an old Perl. The remedy is to simply +use the OO version; e.g.: + + $SH->seek(0,0); ### GOOD: will work on any 5.005 + seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond + + +=head1 VERSION + +$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHORS + +=head2 Primary Maintainer + +David F. Skoll (F). + +=head2 Principal author + +Eryq (F). +President, ZeeGee Software Inc (F). + + +=head2 Other contributors + +The full set of contributors always includes the folks mentioned +in L. But just the same, special +thanks to the following individuals for their invaluable contributions +(if I've forgotten or misspelled your name, please email me!): + +I +for contributing C. + +I +for suggesting C. + +I +for finding and fixing the bug in C. + +I +for his offset-using read() and write() implementations. + +I +for his patches to massively improve the performance of C +and add C and C. + +I +for stringification and inheritance improvements, +and sundry good ideas. + +I +for the IO::Handle inheritance and automatic tie-ing. + + +=head1 SEE ALSO + +L, which is quite similar but which was designed +more-recently and with an IO::Handle-like interface in mind, +so you could mix OO- and native-filehandle usage without using tied(). + +I as of version 2.x, these classes all work like +their IO::Handle counterparts, so we have comparable +functionality to IO::String. + +=cut + diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index a5d8eba73e..2322d8a9b7 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -2,27 +2,18 @@ package Test::Builder::Module; use strict; -use Test::Stream 1.301001 '-internal'; -use Test::Builder 0.99; +use Test::Builder 1.00; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.301001_098'; +our $VERSION = '1.001014'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -=pod - -=encoding UTF-8 =head1 NAME -Test::Builder::Module - *DEPRECATED* Base class for test modules - -=head1 DEPRECATED - -B See L for what you should -use instead. +Test::Builder::Module - Base class for test modules =head1 SYNOPSIS @@ -38,15 +29,12 @@ use instead. my $tb = $CLASS->builder; return $tb->ok(@_); } - + 1; =head1 DESCRIPTION -B See L for what you should -use instead. - This is a superclass for L-based modules. It provides a handful of common functionality and a method of getting at the underlying L object. @@ -68,8 +56,8 @@ same basic way as L's, setting the plan and controlling exporting of functions and variables. This allows your module to set the plan independent of L. -All arguments passed to C are passed onto -C<< Your::Module->builder->plan() >> with the exception of +All arguments passed to C 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; @@ -88,14 +76,12 @@ C. sub import { my($class) = shift; - my $test = $class->builder; - my $caller = caller; - - warn __PACKAGE__ . " is deprecated!\n" if $caller->can('TB_INSTANCE') && $caller->TB_INSTANCE->modern; - # 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); @@ -185,103 +171,3 @@ sub builder { } 1; - -__END__ - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm index 8762147c70..b0554b89ac 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,28 +1,17 @@ package Test::Builder::Tester; use strict; -our $VERSION = '1.301001_098'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +our $VERSION = "1.28"; -use Test::Stream 1.301001 '-internal'; -use Test::Builder 1.301001; +use Test::Builder 0.99; use Symbol; -use Test::Stream::Carp qw/croak/; - -=pod - -=encoding UTF-8 +use Carp; =head1 NAME -Test::Builder::Tester - *DEPRECATED* test testsuites that have been built with +Test::Builder::Tester - test testsuites that have been built with Test::Builder -=head1 DEPRECATED - -B Please see L for a -better alternative that does not involve dealing with TAP/string output. - =head1 SYNOPSIS use Test::Builder::Tester tests => 1; @@ -59,55 +48,37 @@ output. # set up testing #### -#my $t = Test::Builder->new; +my $t = Test::Builder->new; ### # make us an exporter ### -use Test::Stream::Toolset; -use Test::Stream::Exporter; -default_exports qw/test_out test_err test_fail test_diag test_test line_num/; -Test::Stream::Exporter->cleanup; +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); -sub before_import { +sub import { my $class = shift; - my ($importer, $list) = @_; + my(@plan) = @_; - my $meta = init_tester($importer); - my $context = context(1); - my $other = []; - my $idx = 0; + my $caller = caller; - while ($idx <= $#{$list}) { - my $item = $list->[$idx++]; - next unless $item; + $t->exported_to($caller); + $t->plan(@plan); - if (defined $item and $item eq 'no_diag') { - Test::Stream->shared->set_no_diag(1); - } - elsif ($item eq 'tests') { - $context->plan($list->[$idx++]); - } - elsif ($item eq 'skip_all') { - $context->plan(0, 'SKIP', $list->[$idx++]); - } - elsif ($item eq 'no_plan') { - $context->plan(0, 'NO PLAN'); - } - elsif ($item eq 'import') { - push @$other => @{$list->[$idx++]}; + my @imports = (); + foreach my $idx ( 0 .. $#plan ) { + if( $plan[$idx] eq 'import' ) { + @imports = @{ $plan[ $idx + 1 ] }; + last; } } - @$list = @$other; - - return; + __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); } - -sub builder { Test::Builder->new } - ### # set up file handles ### @@ -129,9 +100,6 @@ my $testing = 0; my $testing_num; my $original_is_passing; -my $original_stream; -my $original_state; - # remembering where the file handles were originally connected my $original_output_handle; my $original_failure_handle; @@ -146,18 +114,15 @@ sub _start_testing { $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; - $original_stream = builder->{stream} || Test::Stream->shared; - $original_state = [@{$original_stream->state->[-1]}]; - # remember what the handles were set to - $original_output_handle = builder()->output(); - $original_failure_handle = builder()->failure_output(); - $original_todo_handle = builder()->todo_output(); + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); # switch out to our own handles - builder()->output($output_handle); - builder()->failure_output($error_handle); - builder()->todo_output($output_handle); + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($output_handle); # clear the expected list $out->reset(); @@ -165,13 +130,13 @@ sub _start_testing { # remember that we're testing $testing = 1; - $testing_num = builder()->current_test; - builder()->current_test(0); - $original_is_passing = builder()->is_passing; - builder()->is_passing(1); + $testing_num = $t->current_test; + $t->current_test(0); + $original_is_passing = $t->is_passing; + $t->is_passing(1); # look, we shouldn't do the ending stuff - builder()->no_ending(1); + $t->no_ending(1); } =head2 Functions @@ -209,7 +174,6 @@ output filehandles) =cut sub test_out { - my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; @@ -217,7 +181,6 @@ sub test_out { } sub test_err { - my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; @@ -251,7 +214,6 @@ more simply as: =cut sub test_fail { - my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; @@ -294,13 +256,12 @@ without the newlines. =cut sub test_diag { - my $ctx = context; # do we need to do any setup? _start_testing() unless $testing; # expect the same thing, but prepended with "# " local $_; - $err->expect( map { m/\S/ ? "# $_" : "" } @_ ); + $err->expect( map { "# $_" } @_ ); } =item test_test @@ -343,7 +304,6 @@ will function normally and cause success/errors for L. =cut sub test_test { - my $ctx = context; # decode the arguments as described in the pod my $mess; my %args; @@ -362,23 +322,21 @@ sub test_test { unless $testing; # okay, reconnect the test suite back to the saved handles - builder()->output($original_output_handle); - builder()->failure_output($original_failure_handle); - builder()->todo_output($original_todo_handle); + $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 - builder()->current_test($testing_num); + $t->current_test($testing_num); $testing = 0; - builder()->is_passing($original_is_passing); + $t->is_passing($original_is_passing); # re-enable the original setting of the harness $ENV{HARNESS_ACTIVE} = $original_harness_env; - @{$original_stream->state->[-1]} = @$original_state; - # check the output we've stashed - unless( builder()->ok( ( $args{skip_out} || $out->check ) && - ( $args{skip_err} || $err->check ), $mess ) + unless( $t->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) ) { # print out the diagnostic information about why this @@ -386,10 +344,10 @@ sub test_test { local $_; - builder()->diag( map { "$_\n" } $out->complaint ) + $t->diag( map { "$_\n" } $out->complaint ) unless $args{skip_out} || $out->check; - builder()->diag( map { "$_\n" } $err->complaint ) + $t->diag( map { "$_\n" } $err->complaint ) unless $args{skip_err} || $err->check; } } @@ -460,112 +418,48 @@ sub color { =back -=head1 NOTES - -Thanks to Richard Clamp Erichardc@unixbeard.netE for letting -me use his testing system to try this module out on. +=head1 BUGS -=head1 SEE ALSO - -L, L, L. +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. -=head1 SOURCE +The color function doesn't work unless L is +compatible with your terminal. -The source code repository for Test::More can be found at -F. +Bugs (and requests for new features) can be reported to the author +though the CPAN RT system: +L -=head1 MAINTAINER +=head1 AUTHOR -=over 4 +Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. -=item Chad Granum Eexodist@cpan.orgE +Some code taken from L and L, written by +Michael G Schwern Eschwern@pobox.comE. Hence, those parts +Copyright Micheal G Schwern 2001. Used and distributed with +permission. -=back - -=head1 AUTHORS +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). +=head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - =back -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester +=head1 NOTES -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. +Thanks to Richard Clamp Erichardc@unixbeard.netE for letting +me use his testing system to try this module out on. -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. +=head1 SEE ALSO -=back +L, L, L. =cut @@ -593,10 +487,8 @@ sub expect { sub _account_for_subtest { my( $self, $check ) = @_; - my $ctx = Test::Stream::Context::context(); - my $depth = @{$ctx->stream->subtests}; # Since we ship with Test::Builder, calling a private method is safe...ish. - return ref($check) ? $check : ($depth ? ' ' x $depth : '') . $check; + return ref($check) ? $check : $t->_indent . $check; } sub _translate_Failed_check { diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index 675a86a25f..9a89310f1f 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,15 +1,10 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = '1.301001_098'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +our $VERSION = "1.290001"; -use Test::Stream 1.301001 '-internal'; require Test::Builder::Tester; -=pod - -=encoding UTF-8 =head1 NAME @@ -54,103 +49,3 @@ L, L =cut 1; - -__END__ - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/CanFork.pm b/cpan/Test-Simple/lib/Test/CanFork.pm deleted file mode 100644 index c94614cbd8..0000000000 --- a/cpan/Test-Simple/lib/Test/CanFork.pm +++ /dev/null @@ -1,92 +0,0 @@ -package Test::CanFork; -use strict; -use warnings; - -use Config; - -my $Can_Fork = $Config{d_fork} - || (($^O eq 'MSWin32' || $^O eq 'NetWare') - and $Config{useithreads} - and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); - -sub import { - my $class = shift; - - if (!$Can_Fork) { - require Test::More; - Test::More::plan(skip_all => "This system cannot fork"); - } - - if ($^O eq 'MSWin32' && $] == 5.010000) { - require Test::More; - Test::More::plan('skip_all' => "5.10 has fork/threading issues that break fork on win32"); - } - - for my $var (@_) { - next if $ENV{$var}; - - require Test::More; - Test::More::plan(skip_all => "This forking test will only run when the '$var' environment variable is set."); - } -} - -1; - -__END__ - -=head1 NAME - -Test::CanFork - Only run tests when forking is supported, optionally conditioned on ENV vars. - -=head1 DESCRIPTION - -Use this first thing in a test that should be skipped when forking is not -supported. You can also specify that the test should be skipped when specific -environment variables are not set. - -=head1 SYNOPSYS - -Skip the test if forking is unsupported: - - use Test::CanFork; - use Test::More; - ... - -Skip the test if forking is unsupported, or any of the specified env vars are -not set: - - use Test::CanFork qw/AUTHOR_TESTING RUN_PROBLEMATIC_TESTS .../; - use Test::More; - ... - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/cpan/Test-Simple/lib/Test/CanThread.pm b/cpan/Test-Simple/lib/Test/CanThread.pm deleted file mode 100644 index 0e022f028b..0000000000 --- a/cpan/Test-Simple/lib/Test/CanThread.pm +++ /dev/null @@ -1,119 +0,0 @@ -package Test::CanThread; -use strict; -use warnings; - -use Config; - -my $works = 1; -$works &&= $] >= 5.008001; -$works &&= $Config{'useithreads'}; -$works &&= eval { require threads; 'threads'->import; 1 }; - -sub import { - my $class = shift; - - unless ($works) { - require Test::More; - Test::More::plan(skip_all => "Skip no working threads"); - } - - if ($INC{'Devel/Cover.pm'}) { - require Test::More; - Test::More::plan(skip_all => "Devel::Cover does not work with threads yet"); - } - - while(my $var = shift(@_)) { - next if $ENV{$var}; - - require Test::More; - Test::More::plan(skip_all => "This threaded test will only run when the '$var' environment variable is set."); - } - - if ($] == 5.010000) { - require File::Temp; - require File::Spec; - - my $perl = File::Spec->rel2abs($^X); - my ($fh, $fn) = File::Temp::tempfile(); - print $fh <<' EOT'; - BEGIN { print STDERR "# Checking for thread segfaults\n# " } - use threads; - my $t = threads->create(sub { 1 }); - $t->join; - print STDERR "Threads appear to work\n"; - exit 0; - EOT - close($fh); - - my $exit = system(qq{"$perl" "$fn"}); - - if ($exit) { - require Test::More; - Test::More::plan(skip_all => "Threads segfault on this perl"); - } - } - - my $caller = caller; - eval "package $caller; use threads; 1" || die $@; -} - -1; - -__END__ - -=head1 NAME - -Test::CanThread - Only run tests when threading is supported, optionally conditioned on ENV vars. - -=head1 DESCRIPTION - -Use this first thing in a test that should be skipped when threading is not -supported. You can also specify that the test should be skipped when specific -environment variables are not set. - -=head1 SYNOPSYS - -Skip the test if threading is unsupported: - - use Test::CanThread; - use Test::More; - ... - -Skip the test if threading is unsupported, or any of the specified env vars are -not set: - - use Test::CanThread qw/AUTHOR_TESTING RUN_PROBLEMATIC_TESTS .../; - use Test::More; - ... - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/cpan/Test-Simple/lib/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm index 8b812acf23..4bab267fcf 100644 --- a/cpan/Test-Simple/lib/Test/More.pm +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -1,469 +1,97 @@ package Test::More; -use 5.008001; +use 5.006; use strict; use warnings; -our $VERSION = '1.301001_098'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) - -use Test::Stream 1.301001 '-internal'; -use Test::Stream::Util qw/protect try spoof/; -use Test::Stream::Toolset qw/is_tester init_tester context before_import/; -use Test::Stream::Subtest qw/subtest/; - -use Test::Stream::Carp qw/croak carp/; -use Scalar::Util qw/blessed/; - -use Test::More::Tools; -use Test::More::DeepCheck::Strict; - -use Test::Builder; - -use Test::Stream::Exporter qw/ - default_export default_exports export_to export_to_level -/; - -our $TODO; -default_export '$TODO' => \$TODO; -default_exports qw{ - plan done_testing +#---- perlcritic exemptions. ----# - ok - is isnt - like unlike - cmp_ok - is_deeply - eq_array eq_hash eq_set - can_ok isa_ok new_ok - pass fail - require_ok use_ok - subtest - - explain - - diag note - - skip todo_skip - BAIL_OUT -}; -Test::Stream::Exporter->cleanup; - -{ - no warnings 'once'; - $Test::Builder::Level ||= 1; -} - -sub import { - my $class = shift; - my $caller = caller; - my @args = @_; +# We use a lot of subroutine prototypes +## no critic (Subroutines::ProhibitSubroutinePrototypes) - my $stash = $class->before_import($caller, \@args) if $class->can('before_import'); - export_to($class, $caller, @args); - $class->after_import($caller, $stash, @args) if $class->can('after_import'); - $class->import_extra(@args); +# Can't use Carp because it might cause C 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"; } -sub import_extra { 1 }; - -sub builder { Test::Builder->new } - -sub ok ($;$) { - my ($test, $name) = @_; - my $ctx = context(); - if($test) { - $ctx->ok(1, $name); - return 1; - } - else { - $ctx->ok(0, $name); - return 0; - } -} - -sub plan { - return unless @_; - my ($directive, $arg) = @_; - my $ctx = context(); - - if ($directive eq 'tests') { - $ctx->plan($arg); - } - else { - $ctx->plan(0, $directive, $arg); - } -} - -sub done_testing { - my ($num) = @_; - my $ctx = context(); - $ctx->done_testing($num); -} - -sub is($$;$) { - my ($got, $want, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = tmt->is_eq($got, $want); - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -sub isnt ($$;$) { - my ($got, $forbid, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = tmt->isnt_eq($got, $forbid); - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -{ - no warnings 'once'; - *isn't = \&isnt; - # ' to unconfuse syntax higlighters -} - -sub like ($$;$) { - my ($got, $check, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = tmt->regex_check($got, $check, '=~'); - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -sub unlike ($$;$) { - my ($got, $forbid, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = tmt->regex_check($got, $forbid, '!~'); - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -sub cmp_ok($$$;$) { - my ($got, $type, $expect, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = tmt->cmp_check($got, $type, $expect); - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -sub can_ok($@) { - my ($thing, @methods) = @_; - my $ctx = context(); - - my $class = ref $thing || $thing || ''; - my ($ok, @diag); - - if (!@methods) { - ($ok, @diag) = (0, " can_ok() called with no methods"); - } - elsif (!$class) { - ($ok, @diag) = (0, " can_ok() called with empty class or reference"); - } - else { - ($ok, @diag) = tmt->can_check($thing, $class, @methods); - } - - my $name = (@methods == 1 && defined $methods[0]) - ? "$class\->can('$methods[0]')" - : "$class\->can(...)"; - - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -sub isa_ok ($$;$) { - my ($thing, $class, $thing_name) = @_; - my $ctx = context(); - $thing_name = "'$thing_name'" if $thing_name; - my ($ok, @diag) = tmt->isa_check($thing, $class, \$thing_name); - my $name = "$thing_name isa '$class'"; - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -sub new_ok { - croak "new_ok() must be given at least a class" unless @_; - my ($class, $args, $object_name) = @_; - my $ctx = context(); - my ($obj, $name, $ok, @diag) = tmt->new_check($class, $args, $object_name); - $ctx->ok($ok, $name, \@diag); - return $obj; -} - -sub pass (;$) { - my $ctx = context(); - return $ctx->ok(1, @_); -} - -sub fail (;$) { - my $ctx = context(); - return $ctx->ok(0, @_); -} - -sub explain { - my $ctx = context(); - tmt->explain(@_); -} - -sub diag { - my $ctx = context(); - $ctx->diag($_) for @_; -} - -sub note { - my $ctx = context(); - $ctx->note($_) for @_; -} - -sub skip { - my( $why, $how_many ) = @_; - my $ctx = context(); - - _skip($why, $how_many, 'skip', 1); - - no warnings 'exiting'; - last SKIP; -} - -sub _skip { - my( $why, $how_many, $func, $bool ) = @_; - my $ctx = context(); - - my $plan = $ctx->stream->plan; - - # If there is no plan we do not need to worry about counts - my $need_count = $plan ? !($plan->directive && $plan->directive eq 'NO PLAN') : 0; - - if ($need_count && !defined $how_many) { - $ctx->alert("$func() needs to know \$how_many tests are in the block"); - } - - $ctx->alert("$func() was passed a non-numeric number of tests. Did you get the arguments backwards?") - if defined $how_many and $how_many =~ /\D/; - - $how_many = 1 unless defined $how_many; - $ctx->set_skip($why); - for( 1 .. $how_many ) { - $ctx->ok($bool, ''); - } -} - -sub todo_skip { - my($why, $how_many) = @_; - - my $ctx = context(); - $ctx->set_in_todo(1); - $ctx->set_todo($why); - _skip($why, $how_many, 'todo_skip', 0); - - no warnings 'exiting'; - last TODO; -} - -sub BAIL_OUT { - my ($reason) = @_; - my $ctx = context(); - $ctx->bail($reason); -} - -sub is_deeply { - my ($got, $want, $name) = @_; - - my $ctx = context(); - - 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 - - $ctx->alert(sprintf $msg, scalar @_); - - $ctx->ok(0, undef, ['incorrect number of args']); - return 0; - } - - my ($ok, @diag) = Test::More::DeepCheck::Strict->check($got, $want); - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -sub eq_array { - my ($got, $want, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = Test::More::DeepCheck::Strict->check_array($got, $want); - return $ok; -} - -sub eq_hash { - my ($got, $want, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = Test::More::DeepCheck::Strict->check_hash($got, $want); - return $ok; -} - -sub eq_set { - my ($got, $want, $name) = @_; - my $ctx = context(); - my ($ok, @diag) = Test::More::DeepCheck::Strict->check_set($got, $want); - return $ok; -} - -sub require_ok($;$) { - my($module) = shift; - my $ctx = context(); - - # Try to determine 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 ($ret, $err); - { - local $SIG{__DIE__}; - ($ret, $err) = spoof [caller] => "require $module"; - } - - my @diag; - unless ($ret) { - chomp $err; - push @diag => <<" DIAG"; - Tried to require '$module'. - Error: $err - DIAG - } - - $ctx->ok( $ret, "require $module;", \@diag ); - return $ret ? 1 : 0; -} - -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; -} - -sub use_ok($;@) { - my ($module, @imports) = @_; - @imports = () unless @imports; - my $ctx = context(); - - my($pack, $filename, $line) = caller; - $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line - - my ($ret, $err, $newdie, @diag); - { - local $SIG{__DIE__}; - - 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. - ($ret, $err) = spoof [$pack, $filename, $line] => "use $module $imports[0]"; - } - else { - ($ret, $err) = spoof [$pack, $filename, $line] => "use $module \@args", @imports; - } - - $newdie = $SIG{__DIE__}; - } - - $SIG{__DIE__} = $newdie if defined $newdie; - - unless ($ret) { - chomp $err; - push @diag => <<" DIAG"; - Tried to use '$module'. - Error: $err - DIAG - } - - $ctx->ok($ret, "use $module;", \@diag); - - return $ret ? 1 : 0; -} - -1; - -__END__ - -=pod +our $VERSION = '1.001014'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -=encoding UTF-8 +use Test::Builder::Module 0.99; +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 + subtest + BAIL_OUT +); =head1 NAME -Test::More - The defacto standard in unit testing tools. +Test::More - yet another framework for writing test scripts =head1 SYNOPSIS - # Using Test::Stream BEFORE using Test::More removes expensive legacy - # support. This Also provides context(), cull(), and tap_encoding() - use Test::Stream; + use Test::More tests => 23; + # or + use Test::More skip_all => $reason; + # or + use Test::More; # see done_testing() - # Load after Test::Stream to get the benefits of removed legacy - use Test::More; + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($got eq $expected, $test_name); - use ok 'Some::Module'; + is ($got, $expected, $test_name); + isnt($got, $expected, $test_name); - can_ok($module, @methods); - isa_ok($object, $class); + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); - pass($test_name); - fail($test_name); + like ($got, qr/expected/, $test_name); + unlike($got, qr/expected/, $test_name); - ok($got eq $expected, $test_name); + cmp_ok($got, '==', $expected, $test_name); - is ($got, $expected, $test_name); - isnt($got, $expected, $test_name); + is_deeply($got_complex_structure, $expected_complex_structure, $test_name); - like ($got, qr/expected/, $test_name); - unlike($got, qr/expected/, $test_name); + SKIP: { + skip $why, $how_many unless $have_some_feature; - cmp_ok($got, '==', $expected, $test_name); + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; - is_deeply( - $got_complex_structure, - $expected_complex_structure, - $test_name - ); + TODO: { + local $TODO = $why; - # Rather than print STDERR "# here's what went wrong\n" - diag("here's what went wrong"); + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; - SKIP: { - skip $why, $how_many unless $have_some_feature; + can_ok($module, @methods); + isa_ok($object, $class); - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; + pass($test_name); + fail($test_name); - TODO: { - local $TODO = $why; - - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; - - sub my_compare { - my ($got, $want, $name) = @_; - my $ctx = context(); # From Test::Stream - my $ok = $got eq $want; - $ctx->ok($ok, $name); - ... - return $ok; - }; + BAIL_OUT($why); - # If this fails it will report this line instead of the line in my_compare. - my_compare('a', 'b'); + # UNIMPLEMENTED!!! + my @status = Test::More::status; - done_testing; =head1 DESCRIPTION @@ -477,6 +105,7 @@ facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. + =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares @@ -531,6 +160,40 @@ or for deciding between running the tests at all: 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 @@ -550,114 +213,12 @@ This is safer than and replaces the "no_plan" plan. =back -=head2 Test::Stream - -If Test::Stream is loaded before Test::More then it will prevent the insertion -of some legacy support shims, saving you memory and improving performance. - - use Test::Stream; - use Test::More; - -You can also use it to make forking work: - - use Test::Stream 'enable_fork'; - -=head2 TAP Encoding - -You can now control the encoding of your TAP output using Test::Stream. - - use Test::Stream; # imports tap_encoding - use Test::More; - - tap_encoding 'utf8'; - -You can also just set 'utf8' it at import time - - use Test::Stream 'utf8'; - -or something other than utf8 - - use Test::Stream encoding => 'latin1'; - -=over 4 - -=item tap_encoding 'utf8'; - -=item tap_encoding 'YOUR_ENCODING'; - -=item tap_encoding 'xxx' => sub { ... }; - -The C function will ensure that any B TAP -output produced by I will be output in the specified encoding. - -You may also provide a codeblock in which case the scope of the encoding change -will only apply to that codeblock. - -B: This is effective only for the current package. Other packages can/may -select other encodings for their TAP output. For packages where none is -specified, the original STDOUT and STDERR settings are used, the results are -unpredictable. - -B: The encoding of the TAP, it is necessary to set to match the -locale of the encoding of the terminal. - -However, in tests code that are performed in a variety of environments, -it can not be assumed in advance the encoding of the locale of the terminal, -it is recommended how to set the encoding to your environment using the -C module. - -The following is an example of code. - - use utf8; - use Test::Stream; - use Test::More; - use Encode::Locale; - - tap_encoding('console_out'); - -B: Filenames are a touchy subject: - -Different OS's and filesystems handle filenames differently. When you do not -specify an encoding, the filename will be unmodified, you get whatever perl -thinks it is. If you do specify an encoding, the filename will be assumed to be -in that encoding, and an attempt will be made to unscramble it. If the -unscrambling fails the original name will be used. - -This filename unscrambling is necessary for example on linux systems when you -use utf8 encoding and a utf8 filename. Perl will read the bytes of the name, -and treat them as bytes. if you then try to print the name to a utf8 handle it -will treat each byte as a different character. Test::More attempts to fix this -scrambling for you. - -=back - -=head2 Helpers - -Sometimes you want to write functions for things you do frequently that include -calling ok() or other test functions. Doing this can make it hard to debug -problems as failures will be reported in your sub, and not at the place where -you called your sub. Now there is a solution to this, the -L object!. - -L exports the C function which will return a context -object for your use. The idea is that you generate a context object at the -lowest level (the function you call from your test file). Deeper functions that -need context will get the object you already generated, at least until the -object falls out of scope or is undefined. +=cut - sub my_compare { - my ($got, $want, $name) = @_; - my $ctx = context(); - - # is() will find the context object above, instead of generating a new - # one. That way a failure will be reported to the correct line - is($got, $want); - - # This time it will generate a new context object. That means a failure - # will report to this line. - $ctx = undef; - is($got, $want); - }; +sub done_testing { + my $tb = Test::More->builder; + $tb->done_testing(@_); +} =head2 Test names @@ -724,6 +285,15 @@ Should an C fail, it will produce some diagnostics: This is the same as L's C routine. +=cut + +sub ok ($;$) { + my( $test, $name ) = @_; + my $tb = Test::More->builder; + + return $tb->ok( $test, $name ); +} + =item B =item B @@ -798,6 +368,23 @@ different from some other value: For those grammatical pedants out there, there's an C function which is an alias of C. +=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; +# ' to unconfuse syntax higlighters + =item B like( $got, qr/expected/, $test_name ); @@ -826,6 +413,14 @@ Regex options may be placed on the end (C<'/expected/i'>). Its advantages over C are similar to that of C and C. Better diagnostics on failure. +=cut + +sub like ($$;$) { + my $tb = Test::More->builder; + + return $tb->like(@_); +} + =item B unlike( $got, qr/expected/, $test_name ); @@ -833,6 +428,14 @@ diagnostics on failure. Works exactly as C, only it checks if $got B match the given pattern. +=cut + +sub unlike ($$;$) { + my $tb = Test::More->builder; + + return $tb->unlike(@_); +} + =item B cmp_ok( $got, $op, $expected, $test_name ); @@ -865,11 +468,20 @@ C's use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); -It's especially useful when comparing greater-than or smaller-than +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($module, @methods); @@ -882,9 +494,9 @@ Checks to make sure the $module or $object can do these @methods is almost exactly like saying: - ok( Foo->can('this') && - Foo->can('that') && - Foo->can('whatever') + ok( Foo->can('this') && + Foo->can('that') && + Foo->can('whatever') ); only without all the typing and with a better interface. Handy for @@ -897,6 +509,40 @@ as one test. If you desire otherwise, use: 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($object, $class, $object_name); @@ -929,6 +575,88 @@ 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( $thing, $class, $thing_name ) = @_; + my $tb = Test::More->builder; + + my $whatami; + if( !defined $thing ) { + $whatami = 'undef'; + } + elsif( ref $thing ) { + $whatami = 'reference'; + + local($@,$!); + require Scalar::Util; + if( Scalar::Util::blessed($thing) ) { + $whatami = 'object'; + } + } + else { + $whatami = 'class'; + } + + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); + + if($error) { + die <isa on your $whatami and got some weird error. +Here's the error. +$error +WHOA + } + + # Special case for isa_ok( [], "ARRAY" ) and like + if( $whatami eq 'reference' ) { + $rslt = UNIVERSAL::isa($thing, $class); + } + + my($diag, $name); + if( defined $thing_name ) { + $name = "'$thing_name' isa '$class'"; + $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; + } + elsif( $whatami eq 'object' ) { + my $my_class = ref $thing; + $thing_name = qq[An object of class '$my_class']; + $name = "$thing_name isa '$class'"; + $diag = "The object of class '$my_class' isn't a '$class'"; + } + elsif( $whatami eq 'reference' ) { + my $type = ref $thing; + $thing_name = qq[A reference of type '$type']; + $name = "$thing_name isa '$class'"; + $diag = "The reference of type '$type' isn't a '$class'"; + } + elsif( $whatami eq 'undef' ) { + $thing_name = 'undef'; + $name = "$thing_name isa '$class'"; + $diag = "$thing_name isn't defined"; + } + elsif( $whatami eq 'class' ) { + $thing_name = qq[The class (or class-like) '$thing']; + $name = "$thing_name isa '$class'"; + $diag = "$thing_name isn't a '$class'"; + } + else { + die; + } + + my $ok; + if($rslt) { + $ok = $tb->ok( 1, $name ); + } + else { + $ok = $tb->ok( 0, $name ); + $tb->diag(" $diag\n"); + } + + return $ok; +} + =item B my $obj = new_ok( $class ); @@ -948,6 +676,31 @@ If @args is not given, an empty list will be used. This function only works on C and it assumes C 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 ||= []; + + 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 { + $class = 'undef' if !defined $class; + $tb->ok( 0, "$class->new() died" ); + $tb->diag(" Error was: $error"); + } + + return $obj; +} + =item B subtest $name => \&code; @@ -959,7 +712,7 @@ result of the whole subtest to determine if its ok or not ok. For example... use Test::More tests => 3; - + pass("First test"); subtest 'An example subtest' => sub { @@ -1009,38 +762,14 @@ subtests are equivalent: done_testing(); }; -B - -Sometimes you want to run a file as a subtest: - - subtest foo => sub { do 'foo.pl' }; - -where foo.pl; - - use Test::More skip_all => "won't work"; - -This will work fine, but will issue a warning. The issue is that the normal -flow control method will now work inside a BEGIN block. The C -statement is run in a BEGIN block. As a result an exception is thrown instead -of the normal flow control. In most cases this works fine. +=cut -A case like this however will have issues: - - subtest foo => sub { - do 'foo.pl'; # Will issue a skip_all - - # You would expect the subtest to stop, but the 'do' captures the - # exception, as a result the following statement does execute. - - ok(0, "blah"); - }; - -You can work around this by cheking the return from C, along with C<$@>, or you can alter foo.pl so that it does this: - - use Test::More; - plan skip_all => 'broken'; +sub subtest { + my ($name, $subtests) = @_; -When the plan is issues outside of the BEGIN block it works just fine. + my $tb = Test::More->builder; + return $tb->subtest(@_); +} =item B @@ -1057,29 +786,22 @@ C and C. Use these very, very, very sparingly. -=back - -=head2 Debugging tests - -Want a stack trace when a test failure occurs? Have some other hook in mind? -Easy! +=cut - use Test::More; - use Carp qw/confess/; +sub pass (;$) { + my $tb = Test::More->builder; - Test::Stream->shared->listen(sub { - my ($stream, $event) = @_; + return $tb->ok( 1, @_ ); +} - # Only care about 'Ok' events (this includes subtests) - return unless $event->isa('Test::Stream::Event::Ok'); +sub fail (;$) { + my $tb = Test::More->builder; - # Only care about failures - return if $event->bool; + return $tb->ok( 0, @_ ); +} - confess "Failed test! here is a stacktrace!"; - }); +=back - ok(0, "This will give you a trace."); =head2 Module tests @@ -1088,44 +810,12 @@ successfully load. For example, you'll often want a first test which simply loads all the modules in the distribution to make sure they work before going on to do more complicated testing. -For such purposes we have C. C is still around, but is -considered discouraged in favor of C. C is also -discouraged because it tries to guess if you gave it a file name or module -name. C's guessing mechanism is broken, but fixing it can break -things. +For such purposes we have C and C. =over 4 -=item B - -=item B - - use ok 'Some::Module'; - use ok 'Another::Module', qw/import_a import_b/; - -This will load the specified module and pass through any extra arguments to -that module. This will also produce a test result. - -B - - my $class = 'My::Module'; - use ok $class; - -The value 'My::Module' is not assigned to the C<$class> variable until -run-time, but the C statement is run at compile time. The result -of this is that we try to load 'undef' as a module. This will generate an -exception: C<'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable?> - -If you must do something like this, here is a more-correct way: - - my $class; - BEGIN { $class = 'My::Module' } - use ok $class; - =item B -B<***DISCOURAGED***> - Broken guessing - require_ok($module); require_ok($file); @@ -1141,18 +831,61 @@ No exception will be thrown if the load fails. # require Some::Module require_ok "Some::Module"; - # require "Some/File.pl"; - require_ok "Some/File.pl"; + # require "Some/File.pl"; + require_ok "Some/File.pl"; + + # stop testing if any of your modules will not load + for my $module (@module) { + require_ok $module or BAIL_OUT "Can't load $module"; + } + +=cut + +sub require_ok ($) { + my($module) = shift; + my $tb = Test::More->builder; + + my $pack = caller; + + # Try to determine 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 = <ok( $eval_result, "require $module;" ); + + unless($ok) { + chomp $eval_error; + $tb->diag(< -B<***DISCOURAGED***> See C - BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } @@ -1200,8 +933,77 @@ import anything, use C. BEGIN { require_ok "Foo" } +=cut + +sub use_ok ($;@) { + my( $module, @imports ) = @_; + @imports = () unless @imports; + my $tb = Test::More->builder; + + my( $pack, $filename, $line ) = caller; + $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line + + 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 = <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(< and L 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(Regexp ARRAY HASH REF SCALAR GLOB CODE)) { + return $type if UNIVERSAL::isa( $thing, $type ); + } + + return ''; +} =back @@ -1286,6 +1194,16 @@ 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 my @dump = explain @diagnostic_message; @@ -1302,6 +1220,12 @@ or note explain \%args; Some::Class->method(%args); +=cut + +sub explain { + return Test::More->builder->explain(@_); +} + =back @@ -1309,7 +1233,7 @@ or Sometimes running a test under certain conditions will cause the test script to die. A certain function or method isn't implemented -(such as C on MacOS), some resource isn't available (like a +(such as C 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). @@ -1362,6 +1286,34 @@ 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: { @@ -1418,6 +1370,26 @@ The syntax and behavior is similar to a C except the tests will be marked as failing but todo. L 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? @@ -1453,8 +1425,18 @@ The test will exit with 255. For even better control look at L. +=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 @@ -1467,7 +1449,7 @@ These functions are usually used inside an C. ok( eq_array(\@got, \@expected) ); -C can do that better and with diagnostics. +C can do that better and with diagnostics. is_deeply( \@got, \@expected ); @@ -1482,6 +1464,146 @@ They may be deprecated in future versions. 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->[$_]; + + next if _equal_nonrefs($e1, $e2); + + 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 _equal_nonrefs { + my( $e1, $e2 ) = @_; + + return if ref $e1 or ref $e2; + + if ( defined $e1 ) { + return 1 if defined $e2 and $e1 eq $e2; + } + else { + return 1 if !defined $e2; + } + + return; +} + +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; + + { + $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 undefined. + $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 my $is_eq = eq_hash(\%got, \%expected); @@ -1489,6 +1611,40 @@ multi-level structures are handled correctly. 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; + + next if _equal_nonrefs($e1, $e2); + + 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 @@ -1514,17 +1670,58 @@ level. The following is an example of a comparison which might not work: L 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 L which provides a single, +Test::More is built on top of L which provides a single, unified backend for any test library to use. This means two test -libraries which both use B be used together in the +libraries which both use B 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 L object like so: + +=over 4 + +=item B + + my $test_builder = Test::More->builder; + +Returns the L object underlying Test::More for you to play +with. + + +=back + + =head1 EXIT CODES If all your tests passed, L will exit with zero (which is @@ -1553,53 +1750,31 @@ Test::More works with Perls as old as 5.8.1. Thread support is not very reliable before 5.10.1, but that's because threads are not very reliable before 5.10.1. -Although Test::More has been a core module in versions of Perl since 5.6.2, -Test::More has evolved since then, and not all of the features you're used to -will be present in the shipped version of Test::More. If you are writing a -module, don't forget to indicate in your package metadata the minimum version -of Test::More that you require. For instance, if you want to use -C but want your test script to run on Perl 5.10.0, you will -need to explicitly require Test::More > 0.88. +Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. Key feature milestones include: =over 4 -=item event stream - -=item forking support - -=item tap encoding - -Test::Builder and Test::More version 1.301001 introduce these major -modernizations. - =item subtests -Subtests were released in Test::More 0.94, which came with Perl 5.12.0. -Subtests did not implicitly call C until 0.96; the first Perl -with that fix was Perl 5.14.0 with 0.98. +Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. =item C -This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as -part of Test::More 0.92. +This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C -Although C was introduced in 0.40, 0.86 fixed an important bug to -make it safe for overloaded objects; the fixed first shipped with Perl in -5.10.1 as part of Test::More 0.92. +Although C was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C C and C -These were was released in Test::More 0.82, and first shipped with Perl in -5.10.1 as part of Test::More 0.92. +These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =back -There is a full version history in the Changes file, and the Test::More -versions included as core can be found using L: +There is a full version history in the Changes file, and the Test::More versions included as core can be found using L: $ corelist -a Test::More @@ -1611,33 +1786,22 @@ versions included as core can be found using L: =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. +might get a "Wide character in print" warning. Using +C<< binmode STDOUT, ":utf8" >> will not fix it. +L (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. -Use the C function to configure the TAP stream encoding. +One work around is to apply encodings to STDOUT and STDERR as early +as possible and before Test::More (or any other Test module) loads. - use utf8; - use Test::Stream; # imports tap_encoding - use Test::More; - tap_encoding 'utf8'; - -L (which powers Test::More) duplicates STDOUT and STDERR. -So any changes to them, including changing their output disciplines, -will not be seen by Test::More. - -B:deprecated ways to use utf8 or other non-ASCII characters. - -In the past it was necessary to alter the filehandle encoding prior to loading -Test::More. This is no longer necessary thanks to C. - - # *** DEPRECATED WAY *** use open ':std', ':encoding(utf8)'; use Test::More; A more direct work around is to change the filehandles used by L. - # *** EVEN MORE DEPRECATED WAY *** my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; @@ -1661,11 +1825,6 @@ complex data structures. =item Threads -B The underlying mechanism to support threads has changed as of version -1.301001. Instead of sharing several variables and locking them, threads now -use the same mechanism as forking support. The new system writes events to temp -files which are culled by the main process. - Test::More will only be aware of threads if C has been done I Test::More is loaded. This is ok: @@ -1699,6 +1858,8 @@ magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO +=head2 + =head2 ALTERNATIVES L if all this confuses you and you just want to write @@ -1746,12 +1907,14 @@ L installs a whole bunch of useful test modules. L Most commonly needed test functions and features. -=head1 SOURCE +=head1 AUTHORS -The source code repository for Test::More can be found at -F. +Michael G Schwern Eschwern@pobox.comE with much inspiration +from Joshua Pritikin's Test module and lots of help from Barrie +Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and +the perl-qa gang. -=head1 MAINTAINER +=head1 MAINTAINERS =over 4 @@ -1759,57 +1922,20 @@ F. =back -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 -=item Chad Granum Eexodist@cpan.orgE +=head1 BUGS -=item Fergal Daly Efergal@esatclear.ie>E +See F to report and view bugs. -=item Mark Fowler Emark@twoshortplanks.comE -=item Michael G Schwern Eschwern@pobox.comE +=head1 SOURCE -=item 唐鳳 +The source code repository for Test::More can be found at +F. -=back =head1 COPYRIGHT -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or @@ -1817,29 +1943,6 @@ modify it under the same terms as Perl itself. See F -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester +=cut -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back +1; diff --git a/cpan/Test-Simple/lib/Test/More/DeepCheck.pm b/cpan/Test-Simple/lib/Test/More/DeepCheck.pm deleted file mode 100644 index 0f9ae9a95b..0000000000 --- a/cpan/Test-Simple/lib/Test/More/DeepCheck.pm +++ /dev/null @@ -1,225 +0,0 @@ -package Test::More::DeepCheck; -use strict; -use warnings; - -use Test::Stream::ArrayBase( - accessors => [qw/seen/], -); - -sub init { - $_[0]->[SEEN] ||= [{}]; -} - -my %PAIRS = ( '{' => '}', '[' => ']' ); -my $DNE = bless [], 'Does::Not::Exist'; - -sub is_dne { ref $_[-1] eq ref $DNE } -sub dne { $DNE }; - -sub preface { "" }; - -sub format_stack { - my $self = shift; - my $start = $self->STACK_START; - my $end = @$self - 1; - - my @Stack = @{$self}[$start .. $end]; - - my @parts1 = (' $got'); - my @parts2 = ('$expected'); - - my $did_arrow = 0; - for my $entry (@Stack) { - next unless $entry; - my $type = $entry->{type} || ''; - my $idx = $entry->{idx}; - my $key = $entry->{key}; - my $wrap = $entry->{wrap}; - - if ($type eq 'HASH') { - unless ($did_arrow) { - push @parts1 => '->'; - push @parts2 => '->'; - $did_arrow++; - } - push @parts1 => "{$idx}"; - push @parts2 => "{$idx}"; - } - elsif ($type eq 'OBJECT') { - push @parts1 => '->'; - push @parts2 => '->'; - push @parts1 => "$idx()"; - push @parts2 => "{$idx}"; - $did_arrow = 0; - } - elsif ($type eq 'ARRAY') { - unless ($did_arrow) { - push @parts1 => '->'; - push @parts2 => '->'; - $did_arrow++; - } - push @parts1 => "[$idx]"; - push @parts2 => "[$idx]"; - } - elsif ($type eq 'REF') { - unshift @parts1 => '${'; - unshift @parts2 => '${'; - push @parts1 => '}'; - push @parts2 => '}'; - } - - if ($wrap) { - my $pair = $PAIRS{$wrap}; - unshift @parts1 => $wrap; - unshift @parts2 => $wrap; - push @parts1 => $pair; - push @parts2 => $pair; - } - } - - my $error = $Stack[-1]->{error}; - chomp($error) if $error; - - my @vals = @{$Stack[-1]{vals}}[0, 1]; - my @vars = ( - join('', @parts1), - join('', @parts2), - ); - - my $out = $self->preface; - for my $idx (0 .. $#vals) { - my $val = $vals[$idx]; - $vals[$idx] = - !defined $val ? 'undef' - : is_dne($val) ? "Does not exist" - : ref $val ? "$val" - : "'$val'"; - } - - $out .= "$vars[0] = $vals[0]\n"; - $out .= "$vars[1] = $vals[1]\n"; - $out .= "$error\n" if $error; - - $out =~ s/^/ /msg; - return $out; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::More::DeepCheck - Base class or is_deeply() and mostly_like() -implementations. - -=head1 DESCRIPTION - -This is the base class for deep check functions provided by L and -L. This class contains all the debugging and diagnostics -code shared betweent he 2 tools. - -Most of this was refactored from the original C implementation. If -you find any bugs or incompatabilities please report them. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm b/cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm deleted file mode 100644 index 5ac69e8809..0000000000 --- a/cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm +++ /dev/null @@ -1,330 +0,0 @@ -package Test::More::DeepCheck::Strict; -use strict; -use warnings; - -use Scalar::Util qw/reftype/; -use Test::More::Tools; -use Test::Stream::Carp qw/cluck confess/; -use Test::Stream::Util qw/try unoverload_str is_regex/; - -use Test::Stream::ArrayBase( - accessors => [qw/stack_start/], - base => 'Test::More::DeepCheck', -); - -sub preface { "Structures begin differing at:\n" } - -sub check { - my $class = shift; - my ($got, $expect) = @_; - - unoverload_str(\$got, \$expect); - my $self = $class->new(); - - # neither is a reference - return tmt->is_eq($got, $expect) - if !ref $got and !ref $expect; - - # one's a reference, one isn't - if (!ref $got xor !ref $expect) { - push @$self => {vals => [$got, $expect], line => __LINE__}; - return (0, $self->format_stack); - } - - push @$self => {vals => [$got, $expect], line => __LINE__}; - my $ok = $self->_deep_check($got, $expect); - return ($ok, $ok ? () : $self->format_stack); -} - -sub check_array { - my $class = shift; - my ($got, $expect) = @_; - my $self = $class->new(); - push @$self => {vals => [$got, $expect], line => __LINE__}; - my $ok = $self->_deep_check($got, $expect); - return ($ok, $ok ? () : $self->format_stack); -} - -sub check_hash { - my $class = shift; - my ($got, $expect) = @_; - my $self = $class->new(); - push @$self => {vals => [$got, $expect], line => __LINE__}; - my $ok = $self->_deep_check($got, $expect); - return ($ok, $ok ? () : $self->format_stack); -} - -sub check_set { - my $class = shift; - my ($got, $expect) = @_; - - return 0 unless @$got == @$expect; - - 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 $class->check_array( - [ grep( ref, @$got ), sort( grep( !ref, @$got ) ) ], - [ grep( ref, @$expect ), sort( grep( !ref, @$expect ) ) ], - ); -} - -sub _deep_check { - my $self = shift; - confess "XXX" unless ref $self; - my($e1, $e2) = @_; - - 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); - - return 0 if defined $e1 xor defined $e2; - return 1 if !defined $e1 and !defined $e2; # Shortcut if they're both undefined. - return 0 if $self->is_dne($e1) xor $self->is_dne($e2); - return 1 if $same_ref and ($e1 eq $e2); - - if ($not_ref) { - push @$self => {type => '', vals => [$e1, $e2], line => __LINE__}; - return 0; - } - - # This avoids picking up the same referenced used twice (such as - # [\$a, \$a]) to be considered circular. - my $seen = {%{$self->[SEEN]->[-1]}}; - push @{$self->[SEEN]} => $seen; - my $ok = $self->_inner_check($seen, $e1, $e2); - pop @{$self->[SEEN]}; - return $ok; -} - -sub _inner_check { - my $self = shift; - my ($seen, $e1, $e2) = @_; - - return $seen->{$e1} if $seen->{$e1} && $seen->{$e1} eq $e2; - $seen->{$e1} = "$e2"; - - my $type1 = reftype($e1) || ''; - my $type2 = reftype($e2) || ''; - my $diff = $type1 ne $type2; - - if ($diff) { - push @$self => {type => 'DIFFERENT', vals => [$e1, $e2], line => __LINE__}; - return 0; - } - - return $self->_check_array($e1, $e2) if $type1 eq 'ARRAY'; - return $self->_check_hash($e1, $e2) if $type1 eq 'HASH'; - - if ($type1 eq 'REF' || $type1 eq 'SCALAR' && !(defined(is_regex($e1)) && defined(is_regex($e2)))) { - push @$self => {type => 'REF', vals => [$e1, $e2], line => __LINE__}; - my $ok = $self->_deep_check($$e1, $$e2); - pop @$self if $ok; - return $ok; - } - - push @$self => {type => $type1, vals => [$e1, $e2], line => __LINE__}; - return 0; -} - -sub _check_array { - my $self = shift; - my ($a1, $a2) = @_; - - if (grep reftype($_) ne 'ARRAY', $a1, $a2) { - cluck "_check_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 ? $self->dne : $a1->[$_]; - my $e2 = $_ > $#$a2 ? $self->dne : $a2->[$_]; - - next if $self->_check_nonrefs($e1, $e2); - - push @$self => {type => 'ARRAY', idx => $_, vals => [$e1, $e2], line => __LINE__}; - $ok = $self->_deep_check($e1, $e2); - pop @$self if $ok; - - last unless $ok; - } - - return $ok; -} - -sub _check_nonrefs { - my $self = shift; - my($e1, $e2) = @_; - - return if ref $e1 or ref $e2; - - if (defined $e1) { - return 1 if defined $e2 and $e1 eq $e2; - } - else { - return 1 if !defined $e2; - } - - return 0; -} - -sub _check_hash { - my $self = shift; - my ($a1, $a2) = @_; - - if (grep {(reftype($_) || '') ne 'HASH' } $a1, $a2) { - cluck "_check_hash passed a non-hash ref"; - return 0; - } - - return 1 if $a1 eq $a2; - - my $ok = 1; - my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; - for my $k (sort keys %$bigger) { - my $e1 = exists $a1->{$k} ? $a1->{$k} : $self->dne; - my $e2 = exists $a2->{$k} ? $a2->{$k} : $self->dne; - - next if $self->_check_nonrefs($e1, $e2); - - push @$self => {type => 'HASH', idx => $k, vals => [$e1, $e2], line => __LINE__}; - $ok = $self->_deep_check($e1, $e2); - pop @$self if $ok; - - last unless $ok; - } - - return $ok; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::More::DeepCheck::Strict - Where is_deeply() is implemented. - -=head1 DESCRIPTION - -This is the package where the code for C from L lives. -This code was refactored into this form, but should remain 100% compatible with -the old implementation. If you find an incompatability please report it. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm b/cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm deleted file mode 100644 index 793b4c05a7..0000000000 --- a/cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm +++ /dev/null @@ -1,332 +0,0 @@ -package Test::More::DeepCheck::Tolerant; -use strict; -use warnings; - -use Test::More::Tools; -use Scalar::Util qw/reftype blessed/; -use Test::Stream::Util qw/try unoverload_str is_regex/; - -use Test::Stream::ArrayBase( - accessors => [qw/stack_start/], - base => 'Test::More::DeepCheck', -); - -sub preface { "First mismatch:\n" }; - -sub check { - my $class = shift; - my ($got, $expect) = @_; - - unoverload_str(\$got, \$expect); - my $self = $class->new(); - - # neither is a reference - return tmt->is_eq($got, $expect) - if !ref $got and !ref $expect; - - push @$self => {type => '', vals => [$got, $expect], line => __LINE__}; - my $ok = $self->_deep_check($got, $expect); - return ($ok, $ok ? () : $self->format_stack); -} - -#============================ - -sub _reftype { - my ($thing) = @_; - my $type = reftype $thing || return ''; - - $type = uc($type); - - return $type unless $type eq 'SCALAR'; - - $type = 'REGEXP' if $type eq 'REGEX' || defined is_regex($thing); - - return $type; -} - -sub _nonref_check { - my ($self) = shift; - my ($got, $expect) = @_; - - my $numeric = $got !~ m/\D/i && $expect !~ m/\D/i; - return $numeric ? $got == $expect : "$got" eq "$expect"; -} - -sub _deep_check { - my ($self) = shift; - my ($got, $expect) = @_; - - return 1 unless defined($got) || defined($expect); - return 0 if defined($got) xor defined($expect); - - my $seen = $self->[SEEN]->[-1]; - return 1 if $seen->{$got} && $seen->{$got} eq $expect; - $seen->{$got} = "$expect"; - - my $etype = _reftype $expect; - my $gtype = _reftype $got; - - return 0 if ($etype && $etype ne 'REGEXP' && !$gtype) || ($gtype && !$etype); - - return $self->_nonref_check($got, $expect) unless $etype; - - ##### Both are refs at this point #### - return 1 if $gtype && $got == $expect; - - if ($etype eq 'REGEXP') { - return "$got" eq "$expect" if $gtype eq 'REGEXP'; # Identical regexp check - return $got =~ $expect; - } - - my $ok = 0; - $seen = {%$seen}; - push @{$self->[SEEN]} => $seen; - if ($etype eq 'ARRAY') { - $ok = $self->_array_check($got, $expect); - } - elsif ($etype eq 'HASH') { - $ok = $self->_hash_check($got, $expect); - } - pop @{$self->[SEEN]}; - - return $ok; -} - -sub _array_check { - my $self = shift; - my ($got, $expect) = @_; - - return 0 if _reftype($got) ne 'ARRAY'; - - for (my $i = 0; $i < @$expect; $i++) { - push @$self => {type => 'ARRAY', idx => $i, vals => [$got->[$i], $expect->[$i]], line => __LINE__}; - $self->_deep_check($got->[$i], $expect->[$i]) || return 0; - pop @$self; - } - - return 1; -} - -sub _hash_check { - my $self = shift; - my ($got, $expect) = @_; - - my $blessed = blessed($got); - my $hashref = _reftype($got) eq 'HASH'; - my $arrayref = _reftype($got) eq 'ARRAY'; - - for my $key (sort keys %$expect) { - # $wrap $direct $field Leftover from wrap - my ($wrap, $direct, $field) = ($key =~ m/^ ([\[\{]?) (:?) ([^\]]*) [\]\}]?$/x); - - if ($wrap) { - if (!$blessed) { - push @$self => { - type => 'OBJECT', - idx => $field, - wrap => $wrap, - vals => ["(EXCEPTION)", $expect->{$key}], - error => "Cannot call method '$field' on an unblessed reference.\n", - line => __LINE__, - }; - return 0; - } - if ($direct) { - push @$self => { - type => 'OBJECT', - idx => $field, - wrap => $wrap, - vals => ['(EXCEPTION)', $expect->{$key}], - error => "'$key' is invalid, cannot wrap($wrap) a direct-access($direct).\n", - line => __LINE__, - }; - return 0; - } - } - - my ($val, $type); - if ($direct || !$blessed) { - if ($arrayref) { - $type = 'ARRAY'; - if ($field !~ m/^-?\d+$/i) { - push @$self => { - type => 'ARRAY', - idx => $field, - vals => ['(EXCEPTION)', $expect->{$key}], - error => "'$field' is not a valid array index\n", - line => __LINE__, - }; - return 0; - } - - # Try, if they specify -1 in an empty array it may throw an exception - my ($success, $error) = try { $val = $got->[$field] }; - if (!$success) { - push @$self => { - type => 'ARRAY', - idx => $field, - vals => ['(EXCEPTION)', $expect->{$key}], - error => $error, - line => __LINE__, - }; - return 0; - } - } - else { - $type = 'HASH'; - $val = $got->{$field}; - } - } - else { - $type = 'OBJECT'; - my ($success, $error) = try { - if ($wrap) { - if ($wrap eq '[') { - $val = [$got->$field()]; - } - elsif ($wrap eq '{') { - $val = {$got->$field()}; - } - else { - die "'$wrap' is not a valid way to wrap a method call"; - } - } - else { - $val = $got->$field(); - } - }; - if (!$success) { - push @$self => { - type => 'OBJECT', - idx => $field, - wrap => $wrap || undef, - vals => ['(EXCEPTION)', $expect->{$key}], - error => $error, - line => __LINE__, - }; - return 0; - } - } - - push @$self => {type => $type, idx => $field, vals => [$val, $expect->{$key}], line => __LINE__, wrap => $wrap || undef}; - $self->_deep_check($val, $expect->{$key}) || return 0; - pop @$self; - } - - return 1; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::More::DeepCheck::Tolerant - Under the hood implementation of -mostly_like() - -=head1 DESCRIPTION - -This is where L is implemented. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/More/Tools.pm b/cpan/Test-Simple/lib/Test/More/Tools.pm deleted file mode 100644 index 1fea46f0e2..0000000000 --- a/cpan/Test-Simple/lib/Test/More/Tools.pm +++ /dev/null @@ -1,506 +0,0 @@ -package Test::More::Tools; -use strict; -use warnings; - -use Test::Stream::Context; - -use Test::Stream::Exporter; -default_exports qw/tmt/; -Test::Stream::Exporter->cleanup; - -use Test::Stream::Util qw/try protect is_regex unoverload_str unoverload_num/; -use Scalar::Util qw/blessed reftype/; - -sub tmt() { __PACKAGE__ } - -# Bad, these are not comparison operators. Should we include more? -my %CMP_OK_BL = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); -my %NUMERIC_CMPS = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); - -sub _cmp_eval { - my ($line, $name, $file, $got, $type, $expect) = @_; - my $test; - # This is so that warnings come out at the caller's level - ## no critic (BuiltinFunctions::ProhibitStringyEval) - eval qq[ -#line $line "(eval in $name) $file" -\$test = (\$got $type \$expect); -1; - ] || die $@; - return $test; -} - -sub cmp_check { - my($class, $got, $type, $expect) = @_; - - my $ctx = context(); - my $name = $ctx->subname; - $name =~ s/^.*:://g; - $name = 'cmp_check' if $name eq '__ANON__'; - $ctx->throw("$type is not a valid comparison operator in $name\()") - if $CMP_OK_BL{$type}; - - my ($p, $file, $line) = $ctx->call; - - my $test = 0; - my ($success, $error) = try { - $test = _cmp_eval($line, $name, $file, $got, $type, $expect); - }; - - my @diag; - push @diag => <<" END" unless $success; -An error occurred while using $type: ------------------------------------- -$error ------------------------------------- - END - - unless($test) { - # Treat overloaded objects as numbers if we're asked to do a - # numeric comparison. - my $unoverload = $NUMERIC_CMPS{$type} - ? \&unoverload_num - : \&unoverload_str; - - $unoverload->(\$got, \$expect); - - if( $type =~ /^(eq|==)$/ ) { - push @diag => $class->_is_diag( $got, $type, $expect ); - } - elsif( $type =~ /^(ne|!=)$/ ) { - push @diag => $class->_isnt_diag( $got, $type ); - } - else { - push @diag => $class->_cmp_diag( $got, $type, $expect ); - } - } - - return($test, @diag); -} - -sub is_eq { - my($class, $got, $expect) = @_; - - if( !defined $got || !defined $expect ) { - # undef only matches undef and nothing else - my $test = !defined $got && !defined $expect; - return ($test, $test ? () : $class->_is_diag($got, 'eq', $expect)); - } - - return $class->cmp_check($got, 'eq', $expect); -} - -sub is_num { - my($class, $got, $expect) = @_; - - if( !defined $got || !defined $expect ) { - # undef only matches undef and nothing else - my $test = !defined $got && !defined $expect; - return ($test, $test ? () : $class->_is_diag($got, '==', $expect)); - } - - return $class->cmp_check($got, '==', $expect); -} - -sub isnt_eq { - my($class, $got, $dont_expect) = @_; - - if( !defined $got || !defined $dont_expect ) { - # undef only matches undef and nothing else - my $test = defined $got || defined $dont_expect; - return ($test, $test ? () : $class->_isnt_diag($got, 'ne')); - } - - return $class->cmp_check($got, 'ne', $dont_expect); -} - -sub isnt_num { - my($class, $got, $dont_expect) = @_; - - if( !defined $got || !defined $dont_expect ) { - # undef only matches undef and nothing else - my $test = defined $got || defined $dont_expect; - return ($test, $test ? () : $class->_isnt_diag($got, '!=')); - } - - return $class->cmp_check($got, '!=', $dont_expect); -} - -sub regex_check { - my($class, $thing, $got_regex, $cmp) = @_; - - my $regex = is_regex($got_regex); - return (0, " '$got_regex' doesn't look much like a regex to me.") - unless defined $regex; - - my $ctx = context(); - my ($p, $file, $line) = $ctx->call; - - my $test; - my $mock = qq{#line $line "$file"\n}; - - my @warnings; - my ($success, $error) = try { - # No point in issuing an uninit warning, they'll see it in the diagnostics - no warnings 'uninitialized'; - ## no critic (BuiltinFunctions::ProhibitStringyEval) - protect { eval $mock . q{$test = $thing =~ /$regex/ ? 1 : 0; 1} || die $@ }; - }; - - return (0, "Exception: $error") unless $success; - - my $negate = $cmp eq '!~'; - - $test = !$test if $negate; - - unless($test) { - $thing = defined $thing ? "'$thing'" : 'undef'; - my $match = $negate ? "matches" : "doesn't match"; - my $diag = sprintf(qq{ \%s\n \%13s '\%s'\n}, $thing, $match, $got_regex); - return (0, $diag); - } - - return (1); -} - -sub can_check { - my ($us, $proto, $class, @methods) = @_; - - my @diag; - for my $method (@methods) { - my $ok; - my ($success, $error) = try { $ok = $proto->can($method) }; - if ($success) { - push @diag => " $class\->can('$method') failed" unless $ok; - } - else { - my $file = __FILE__; - $error =~ s/ at \Q$file\E line \d+//; - push @diag => " $class\->can('$method') failed with an exception:\n $error"; - } - } - - return (!@diag, @diag) -} - -sub isa_check { - my($us, $thing, $class, $thing_name) = @_; - - my ($whatami, $try_isa, $diag, $type); - if( !defined $thing ) { - $whatami = 'undef'; - $$thing_name = "undef" unless defined $$thing_name; - $diag = defined $thing ? "$$thing_name isn't a '$class'" : "$$thing_name isn't defined"; - } - elsif($type = blessed $thing) { - $whatami = 'object'; - $try_isa = 1; - $$thing_name = "An object of class '$type'" unless defined $$thing_name; - $diag = "$$thing_name isn't a '$class'"; - } - elsif($type = ref $thing) { - $whatami = 'reference'; - $$thing_name = "A reference of type '$type'" unless defined $$thing_name; - $diag = "$$thing_name isn't a '$class'"; - } - else { - $whatami = 'class'; - $try_isa = $thing && $thing !~ m/^\d+$/; - $$thing_name = "The class (or class-like) '$thing'" unless defined $$thing_name; - $diag = "$$thing_name isn't a '$class'"; - } - - my $ok; - if ($try_isa) { - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - my ($success, $error) = try { - my $ctx = context(); - my ($p, $f, $l) = $ctx->call; - eval qq{#line $l "$f"\n\$ok = \$thing\->isa(\$class); 1} || die $@; - }; - - die <<" WHOA" unless $success; -WHOA! I tried to call ->isa on your $whatami and got some weird error. -Here's the error. -$error - WHOA - } - else { - # Special case for isa_ok( [], "ARRAY" ) and like - $ok = UNIVERSAL::isa($thing, $class); - } - - return ($ok) if $ok; - return ($ok, " $diag\n"); -} - -sub new_check { - my($us, $class, $args, $object_name) = @_; - - $args ||= []; - - my $obj; - my($success, $error) = try { - my $ctx = context(); - my ($p, $f, $l) = $ctx->call; - eval qq{#line $l "$f"\n\$obj = \$class\->new(\@\$args); 1} || die $@; - }; - if($success) { - $object_name = "'$object_name'" if $object_name; - my ($ok, @diag) = $us->isa_check($obj, $class, \$object_name); - my $name = "$object_name isa '$class'"; - return ($obj, $name, $ok, @diag); - } - else { - $class = 'undef' unless defined $class; - return (undef, "$class->new() died", 0, " Error was: $error"); - } -} - -sub explain { - my ($us, @args) = @_; - protect { require Data::Dumper }; - - return map { - ref $_ - ? do { - my $dumper = Data::Dumper->new( [$_] ); - $dumper->Indent(1)->Terse(1); - $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); - $dumper->Dump; - } - : $_ - } @args; -} - -sub _diag_fmt { - my( $class, $type, $val ) = @_; - - if( defined $$val ) { - if( $type eq 'eq' or $type eq 'ne' ) { - # quote and force string context - $$val = "'$$val'"; - } - else { - # force numeric context - unoverload_num($val); - } - } - else { - $$val = 'undef'; - } - - return; -} - -sub _is_diag { - my( $class, $got, $type, $expect ) = @_; - - $class->_diag_fmt( $type, $_ ) for \$got, \$expect; - - return <<"DIAGNOSTIC"; - got: $got - expected: $expect -DIAGNOSTIC -} - -sub _isnt_diag { - my( $class, $got, $type ) = @_; - - $class->_diag_fmt( $type, \$got ); - - return <<"DIAGNOSTIC"; - got: $got - expected: anything else -DIAGNOSTIC -} - - -sub _cmp_diag { - my( $class, $got, $type, $expect ) = @_; - - $got = defined $got ? "'$got'" : 'undef'; - $expect = defined $expect ? "'$expect'" : 'undef'; - - return <<"DIAGNOSTIC"; - $got - $type - $expect -DIAGNOSTIC -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::More::Tools - Generic form of tools from Test::More. - -=head1 DESCRIPTION - -People used to call L tools within other testing tools. This mostly -works, but it generates events for each call. This package gives you access to -the implementations directly, without generating events for you. This allows -you to create a composite tool without generating extra events. - -=head1 SYNOPSYS - - use Test::More::Tools qw/tmt/; - use Test::Stream::Toolset qw/context/; - - # This is how Test::More::is is implemented - sub my_is { - my ($got, $want, $name) = @_; - - my $ctx = context; - - my ($ok, @diag) = tmt->is_eq($got, $want); - - $ctx->ok($ok, $name, \@diag); - } - -=head1 EXPORTS - -=over 4 - -=item $pkg = tmt() - -Simply returns the string 'Test::More::Tools'; - -=back - -=head1 CLASS METHODS - -Not all methods are listed. The ones that have been omitted are not intuitive, -and probably should not be used at all. - -=over 4 - -=item ($bool, @diag) = tmt->cmp_check($got, $op, $want) - -Check 2 values using the operator specified example: C<$got == $want> - -=item ($bool, @diag) = tmt->is_eq($got, $want) - -String compare. - -=item ($bool, @diag) = tmt->is_num($got, $want) - -Numeric compare. - -=item ($bool, @diag) = tmt->isnt_eq($got, $dont_want) - -String inequality compare. - -=item ($bool, @diag) = tmt->isnt_num($got, $dont_want) - -Numeric inequality compare. - -=item ($bool, @diag) = tmt->regex_check($got, $regex, $op) - -Regex compare. C<$op> may be C<=~> or C. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/MostlyLike.pm b/cpan/Test-Simple/lib/Test/MostlyLike.pm deleted file mode 100644 index 88316094a9..0000000000 --- a/cpan/Test-Simple/lib/Test/MostlyLike.pm +++ /dev/null @@ -1,293 +0,0 @@ -package Test::MostlyLike; -use strict; -use warnings; - -use Test::Stream::Toolset; -use Test::Stream::Exporter; -default_exports qw/mostly_like/; -Test::Stream::Exporter->cleanup; - -use Test::More::DeepCheck::Tolerant; - -sub mostly_like { - my ($got, $want, $name) = @_; - - my $ctx = context(); - - unless( @_ == 2 or @_ == 3 ) { - my $msg = <<'WARNING'; -mostly_like() 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 - - $ctx->alert(sprintf $msg, scalar @_); - - $ctx->ok(0, undef, ['incorrect number of args']); - return 0; - } - - my ($ok, @diag) = Test::More::DeepCheck::Tolerant->check($got, $want); - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -1; - -__END__ -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::MostlyLike - Relaxed checking of deep data structures. - -=head1 SYNOPSYS - - my $got = [qw/foo bar baz/]; - - mostly_like( - $got, - ['foo', qr/a/], - "Deeply nested structure matches (mostly)" - ); - -=head1 DESCRIPTION - -A tool based on C from L. This tool produces nearly -identical diagnostics. This tool gives you extra control by letting you check -only the parts of the structure you care about, ignoring the rest. - -=head1 EXPORTS - -=over 4 - -=item $bool = mostly_like($got, $expect, $name) - -Generates a single ok event with diagnostics to help you find any failures. - -Got should be the data structure you want to test. $expect should be a data -structure representing what you expect to see. Unlike C any keys in -C<$got> that do not I in C<$expect> will be ignored. - -=back - -=head1 WHAT TO EXPECT - -When an a blessed object is encountered in the C<$got> structure, any fields -listed in C<$expect> will be called as methods on the C<$got> object. See the -object/direct element access section below for bypassing this. - -Any keys or attributes in C<$got> will be ignored unless the also I in C<$expect> - -=head1 IGNORING THINGS YOU DO NOT CARE ABOUT - - my $got = { foo => 1, bar => 2 }; - my $expect = { foo => 1 }; - - mostly_like($got, $expect, "Ignores 'bar'"); - -If you want to check that a value is not set: - - my $got = { foo => 1, bar => 2 }; - my $expect = { foo => 1, bar => undef }; - - mostly_like($got, $expect, "Will fail since 'bar' has a value"); - -=head2 EXACT MATCHES - - my $got = 'foo'; - my $expect = 'foo'; - mostly_like($got, $expect, "Check a value directly"); - -Also works for deeply nested structures - - mostly_like( - [ - {stuff => 'foo bar baz'}, - ], - [ - {stuff => 'foo bar baz'}, - ], - "Check a value directly, nested" - ); - -=head2 REGEX MATCHES - - my $got = 'foo bar baz'; - my $expect = qr/bar/; - mostly_like($got, $expect, 'Match'); - -Works nested as well: - - mostly_like( - [ - {stuff => 'foo bar baz'}, - ], - [ - {stuff => qr/bar/}, - ], - "Check a value directly, nested" - ); - -=head2 ARRAY ELEMENT MATCHES - - my $got = [qw/foo bar baz/]; - my $exp = [qw/foo bar/]; - - mostly_like($got, $exp, "Ignores unspecified indexes"); - -You can also just check specific indexes: - - my $got = [qw/foo bar baz/]; - my $exp = { ':1' => 'bar' }; - - mostly_like($got, $exp, "Only checks array index 1"); - -When doing this the index must always be prefixed with ':'. - -=head2 HASH ELEMENT MATCHES - - my $got = { foo => 1, bar => 2 }; - my $exp = { foo => 1 }; - - mostly_like($got, $exp, "Only checks foo"); - -=head2 OBJECT METHOD MATCHES - -=head3 UNALTERED - - sub foo { $_[0]->{foo} } - - my $got = bless {foo => 1}, __PACKAGE__; - my $exp = { foo => 1 }; - - mostly_like($got, $exp, 'Checks the return of $got->foo()'); - -=head3 WRAPPED - -Sometimes methods return lists, in such cases you can wrap them in arrayrefs or -hashrefs: - - sub list { qw/foo bar baz/ } - sub dict { foo => 0, bar => 1, baz => 2 } - - my $got = bless {}, __PACKAGE__; - my $exp = { - '[list]' => [ qw/foo bar baz/ ], - '[dict]' => { foo => 0, bar => 1, baz => 2 }, - }; - mostly_like($got, $exp, "Wrapped the method calls"); - -=head3 DIRECT ELEMENT ACCESS - -Sometimes you want to ignore the methods and get the hash value directly. - - sub foo { die "do not call me" } - - my $got = bless { foo => 'secret' }, __PACKAGE__; - my $exp = { ':foo' => 'secret' }; - - mostly_like($got, $exp, "Did not call the fatal method"); - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -=item Test::MostlyLike - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm index 3ab569324d..56457b407f 100644 --- a/cpan/Test-Simple/lib/Test/Simple.pm +++ b/cpan/Test-Simple/lib/Test/Simple.pm @@ -1,69 +1,17 @@ package Test::Simple; -use 5.008001; +use 5.006; use strict; -use warnings; -our $VERSION = '1.301001_098'; +our $VERSION = '1.001014'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -use Test::Stream 1.301001_098 '-internal'; -use Test::Stream::Toolset; - -use Test::Stream::Exporter; -default_exports qw/ok/; -Test::Stream::Exporter->cleanup; - -sub before_import { - my $class = shift; - my ($importer, $list) = @_; - - my $meta = init_tester($importer); - my $context = context(1); - my $idx = 0; - my $other = []; - while ($idx <= $#{$list}) { - my $item = $list->[$idx++]; - - if (defined $item and $item eq 'no_diag') { - Test::Stream->shared->set_no_diag(1); - } - elsif ($item eq 'tests') { - $context->plan($list->[$idx++]); - } - elsif ($item eq 'skip_all') { - $context->plan(0, 'SKIP', $list->[$idx++]); - } - elsif ($item eq 'no_plan') { - $context->plan(0, 'NO PLAN'); - } - elsif ($item eq 'import') { - push @$other => @{$list->[$idx++]}; - } - else { - $context->throw("Unknown option: $item"); - } - } - - @$list = @$other; - - return; -} - -sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) - my $ctx = context(); - return $ctx->ok(@_); - return $_[0] ? 1 : 0; -} - -1; - -__END__ - -=pod +use Test::Builder::Module 0.99; +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok); -=encoding UTF-8 +my $CLASS = __PACKAGE__; =head1 NAME @@ -75,6 +23,7 @@ Test::Simple - Basic utilities for writing tests. ok( $foo eq $bar, 'foo is bar' ); + =head1 DESCRIPTION ** If you are unfamiliar with testing B first!> ** @@ -125,6 +74,12 @@ All tests are run in scalar context. So this: 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 @@ -238,100 +193,29 @@ programs and things will still work). Look in L's SEE ALSO for more testing modules. -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back =head1 AUTHORS -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +Eschwern@pobox.comE, wardrobe by Calvin Klein. + +=head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - =back =head1 COPYRIGHT -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. -This program is free software; you can redistribute it and/or +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. +=cut -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back +1; diff --git a/cpan/Test-Simple/lib/Test/Stream.pm b/cpan/Test-Simple/lib/Test/Stream.pm deleted file mode 100644 index 1c05f1d75f..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream.pm +++ /dev/null @@ -1,1184 +0,0 @@ -package Test::Stream; -use strict; -use warnings; - -our $VERSION = '1.301001_098'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) - -use Test::Stream::Context qw/context/; -use Test::Stream::Threads; -use Test::Stream::IOSets; -use Test::Stream::Util qw/try/; -use Test::Stream::Carp qw/croak confess carp/; -use Test::Stream::Meta qw/MODERN ENCODING init_tester/; - -use Test::Stream::ArrayBase( - accessors => [qw{ - no_ending no_diag no_header - pid tid - state - subtests - subtest_tap_instant - subtest_tap_delayed - mungers - listeners - follow_ups - bailed_out - exit_on_disruption - use_tap use_legacy _use_fork - use_numbers - io_sets - event_id - in_subthread - }], -); - -sub STATE_COUNT() { 0 } -sub STATE_FAILED() { 1 } -sub STATE_PLAN() { 2 } -sub STATE_PASSING() { 3 } -sub STATE_LEGACY() { 4 } -sub STATE_ENDED() { 5 } - -sub OUT_STD() { 0 } -sub OUT_ERR() { 1 } -sub OUT_TODO() { 2 } - -use Test::Stream::Exporter; -exports qw/ - OUT_STD OUT_ERR OUT_TODO - STATE_COUNT STATE_FAILED STATE_PLAN STATE_PASSING STATE_LEGACY STATE_ENDED -/; -default_exports qw/ cull tap_encoding context /; -Test::Stream::Exporter->cleanup; - -sub tap_encoding { - my ($encoding) = @_; - - require Encode; - - croak "encoding '$encoding' is not valid, or not available" - unless $encoding eq 'legacy' || Encode::find_encoding($encoding); - - require Test::Stream::Context; - my $ctx = Test::Stream::Context::context(); - $ctx->stream->io_sets->init_encoding($encoding); - - my $meta = init_tester($ctx->package); - $meta->[ENCODING] = $encoding; -} - -sub cull { - my $ctx = Test::Stream::Context::context(); - $ctx->stream->fork_cull(); -} - -sub before_import { - my $class = shift; - my ($importer, $list) = @_; - - if (@$list && $list->[0] eq '-internal') { - shift @$list; - return; - } - - my $meta = init_tester($importer); - $meta->[MODERN] = 1; - - my $other = []; - my $idx = 0; - my $stream = $class->shared; - - while ($idx <= $#{$list}) { - my $item = $list->[$idx++]; - next unless $item; - - if ($item eq 'subtest_tap') { - my $val = $list->[$idx++]; - if (!$val || $val eq 'none') { - $stream->set_subtest_tap_instant(0); - $stream->set_subtest_tap_delayed(0); - } - elsif ($val eq 'instant') { - $stream->set_subtest_tap_instant(1); - $stream->set_subtest_tap_delayed(0); - } - elsif ($val eq 'delayed') { - $stream->set_subtest_tap_instant(0); - $stream->set_subtest_tap_delayed(1); - } - elsif ($val eq 'both') { - $stream->set_subtest_tap_instant(1); - $stream->set_subtest_tap_delayed(1); - } - else { - croak "'$val' is not a valid option for '$item'"; - } - } - elsif ($item eq 'utf8') { - $stream->io_sets->init_encoding('utf8'); - $meta->[ENCODING] = 'utf8'; - } - elsif ($item eq 'encoding') { - my $encoding = $list->[$idx++]; - - croak "encoding '$encoding' is not valid, or not available" - unless Encode::find_encoding($encoding); - - $stream->io_sets->init_encoding($encoding); - $meta->[ENCODING] = $encoding; - } - elsif ($item eq 'enable_fork') { - $stream->use_fork; - } - else { - push @$other => $item; - } - } - - @$list = @$other; - - return; -} - -sub plan { $_[0]->[STATE]->[-1]->[STATE_PLAN] } -sub count { $_[0]->[STATE]->[-1]->[STATE_COUNT] } -sub failed { $_[0]->[STATE]->[-1]->[STATE_FAILED] } -sub ended { $_[0]->[STATE]->[-1]->[STATE_ENDED] } -sub legacy { $_[0]->[STATE]->[-1]->[STATE_LEGACY] } - -sub is_passing { - my $self = shift; - - if (@_) { - ($self->[STATE]->[-1]->[STATE_PASSING]) = @_; - } - - my $current = $self->[STATE]->[-1]->[STATE_PASSING]; - - my $plan = $self->[STATE]->[-1]->[STATE_PLAN]; - return $current if $self->[STATE]->[-1]->[STATE_ENDED]; - return $current unless $plan; - return $current unless $plan->max; - return $current if $plan->directive && $plan->directive eq 'NO PLAN'; - return $current unless $self->[STATE]->[-1]->[STATE_COUNT] > $plan->max; - - return $self->[STATE]->[-1]->[STATE_PASSING] = 0; -} - -sub init { - my $self = shift; - - $self->[PID] = $$; - $self->[TID] = get_tid(); - $self->[STATE] = [[0, 0, undef, 1]]; - $self->[USE_TAP] = 1; - $self->[USE_NUMBERS] = 1; - $self->[IO_SETS] = Test::Stream::IOSets->new; - $self->[EVENT_ID] = 1; - $self->[NO_ENDING] = 1; - $self->[SUBTESTS] = []; - - $self->[SUBTEST_TAP_INSTANT] = 1; - $self->[SUBTEST_TAP_DELAYED] = 0; - - $self->use_fork if USE_THREADS; - - $self->[EXIT_ON_DISRUPTION] = 1; -} - -{ - my ($root, @stack, $magic); - - END { - $root->fork_cull if $root && $root->_use_fork && $$ == $root->[PID]; - $magic->do_magic($root) if $magic && $root && !$root->[NO_ENDING] - } - - sub _stack { @stack } - - sub shared { - my ($class) = @_; - return $stack[-1] if @stack; - - @stack = ($root = $class->new(0)); - $root->[NO_ENDING] = 0; - - require Test::Stream::Context; - require Test::Stream::Event::Finish; - require Test::Stream::ExitMagic; - require Test::Stream::ExitMagic::Context; - - $magic = Test::Stream::ExitMagic->new; - - return $root; - } - - sub clear { - $root->[NO_ENDING] = 1; - $root = undef; - $magic = undef; - @stack = (); - } - - sub intercept_start { - my $class = shift; - my ($new) = @_; - - my $old = $stack[-1]; - - unless($new) { - $new = $class->new(); - - $new->set_exit_on_disruption(0); - $new->set_use_tap(0); - $new->set_use_legacy(0); - } - - push @stack => $new; - - return ($new, $old); - } - - sub intercept_stop { - my $class = shift; - my ($current) = @_; - croak "Stream stack inconsistency" unless $current == $stack[-1]; - pop @stack; - } -} - -sub intercept { - my $class = shift; - my ($code) = @_; - - croak "The first argument to intercept must be a coderef" - unless $code && ref $code && ref $code eq 'CODE'; - - my ($new, $old) = $class->intercept_start(); - my ($ok, $error) = try { $code->($new, $old) }; - $class->intercept_stop($new); - - die $error unless $ok; - return $ok; -} - -sub listen { - my $self = shift; - for my $sub (@_) { - next unless $sub; - - croak "listen only takes coderefs for arguments, got '$sub'" - unless ref $sub && ref $sub eq 'CODE'; - - push @{$self->[LISTENERS]} => $sub; - } -} - -sub munge { - my $self = shift; - for my $sub (@_) { - next unless $sub; - - croak "munge only takes coderefs for arguments, got '$sub'" - unless ref $sub && ref $sub eq 'CODE'; - - push @{$self->[MUNGERS]} => $sub; - } -} - -sub follow_up { - my $self = shift; - for my $sub (@_) { - next unless $sub; - - croak "follow_up only takes coderefs for arguments, got '$sub'" - unless ref $sub && ref $sub eq 'CODE'; - - push @{$self->[FOLLOW_UPS]} => $sub; - } -} - -sub use_fork { - require File::Temp; - require Storable; - - $_[0]->[_USE_FORK] ||= File::Temp::tempdir(CLEANUP => 0); - confess "Could not get a temp dir" unless $_[0]->[_USE_FORK]; - if ($^O eq 'VMS') { - require VMS::Filespec; - $_[0]->[_USE_FORK] = VMS::Filespec::unixify($_[0]->[_USE_FORK]); - } - return 1; -} - -sub fork_out { - my $self = shift; - - my $tempdir = $self->[_USE_FORK]; - confess "Fork support has not been turned on!" unless $tempdir; - - my $tid = get_tid(); - - for my $event (@_) { - next unless $event; - next if $event->isa('Test::Stream::Event::Finish'); - - # First write the file, then rename it so that it is not read before it is ready. - my $name = $tempdir . "/$$-$tid-" . ($self->[EVENT_ID]++); - my ($ret, $err) = try { Storable::store($event, $name) }; - # Temporary to debug an error on one cpan-testers box - unless ($ret) { - require Data::Dumper; - confess(Data::Dumper::Dumper({ error => $err, event => $event})); - } - rename($name, "$name.ready") || confess "Could not rename file '$name' -> '$name.ready'"; - } -} - -sub fork_cull { - my $self = shift; - - confess "fork_cull() can only be called from the parent process!" - if $$ != $self->[PID]; - - confess "fork_cull() can only be called from the parent thread!" - if get_tid() != $self->[TID]; - - my $tempdir = $self->[_USE_FORK]; - confess "Fork support has not been turned on!" unless $tempdir; - - opendir(my $dh, $tempdir) || croak "could not open temp dir ($tempdir)!"; - - my @files = sort readdir($dh); - for my $file (@files) { - next if $file =~ m/^\.+$/; - next unless $file =~ m/\.ready$/; - - # Untaint the path. - my $full = "$tempdir/$file"; - ($full) = ($full =~ m/^(.*)$/gs); - - my $obj = Storable::retrieve($full); - confess "Empty event object found '$full'" unless $obj; - - if ($ENV{TEST_KEEP_TMP_DIR}) { - rename($full, "$full.complete") - || confess "Could not rename file '$full', '$full.complete'"; - } - else { - unlink($full) || die "Could not unlink file: $file"; - } - - my $cache = $self->_update_state($self->[STATE]->[0], $obj); - $self->_process_event($obj, $cache); - $self->_finalize_event($obj, $cache); - } - - closedir($dh); -} - -sub done_testing { - my $self = shift; - my ($ctx, $num) = @_; - my $state = $self->[STATE]->[-1]; - - if (my $old = $state->[STATE_ENDED]) { - my ($p1, $f1, $l1) = $old->call; - $ctx->ok(0, "done_testing() was already called at $f1 line $l1"); - return; - } - - # Do not run followups in subtest! - if ($self->[FOLLOW_UPS] && !@{$self->[SUBTESTS]}) { - $_->($ctx) for @{$self->[FOLLOW_UPS]}; - } - - $state->[STATE_ENDED] = $ctx->snapshot; - - my $ran = $state->[STATE_COUNT]; - my $plan = $state->[STATE_PLAN] ? $state->[STATE_PLAN]->max : 0; - - if (defined($num) && $plan && $num != $plan) { - $ctx->ok(0, "planned to run $plan but done_testing() expects $num"); - return; - } - - # Use _plan to bypass Test::Builder::plan() monkeypatching - $ctx->_plan($num || $plan || $ran) unless $state->[STATE_PLAN]; - - if ($plan && $plan != $ran) { - $state->[STATE_PASSING] = 0; - return; - } - - if ($num && $num != $ran) { - $state->[STATE_PASSING] = 0; - return; - } - - unless ($ran) { - $state->[STATE_PASSING] = 0; - return; - } -} - -sub subtest_start { - my $self = shift; - my ($name, %params) = @_; - - my $state = [0, 0, undef, 1]; - - $params{parent_todo} ||= Test::Stream::Context::context->in_todo; - - if(@{$self->[SUBTESTS]}) { - $params{parent_todo} ||= $self->[SUBTESTS]->[-1]->{parent_todo}; - } - - push @{$self->[STATE]} => $state; - push @{$self->[SUBTESTS]} => { - instant => $self->[SUBTEST_TAP_INSTANT], - delayed => $self->[SUBTEST_TAP_DELAYED], - - %params, - - state => $state, - events => [], - name => $name, - }; - - return $self->[SUBTESTS]->[-1]; -} - -sub subtest_stop { - my $self = shift; - my ($name) = @_; - - confess "No subtest to stop!" - unless @{$self->[SUBTESTS]}; - - confess "Subtest name mismatch!" - unless $self->[SUBTESTS]->[-1]->{name} eq $name; - - my $st = pop @{$self->[SUBTESTS]}; - pop @{$self->[STATE]}; - - return $st; -} - -sub subtest { @{$_[0]->[SUBTESTS]} ? $_[0]->[SUBTESTS]->[-1] : () } - -sub send { - my ($self, $e) = @_; - - my $cache = $self->_update_state($self->[STATE]->[-1], $e); - - # Subtests get dibbs on events - if (my $num = @{$self->[SUBTESTS]}) { - my $st = $self->[SUBTESTS]->[-1]; - - $e->set_in_subtest($num); - $e->context->set_diag_todo(1) if $st->{parent_todo}; - - push @{$st->{events}} => $e; - - $self->_render_tap($cache) if $st->{instant} && !$cache->{no_out}; - } - elsif($self->[_USE_FORK] && ($$ != $self->[PID] || get_tid() != $self->[TID])) { - $self->fork_out($e); - } - else { - $self->_process_event($e, $cache); - } - - $self->_finalize_event($e, $cache); - - return $e; -} - -sub _update_state { - my ($self, $state, $e) = @_; - my $cache = {tap_event => $e, state => $state}; - - if ($e->isa('Test::Stream::Event::Ok')) { - $cache->{do_tap} = 1; - $state->[STATE_COUNT]++; - if (!$e->bool) { - $state->[STATE_FAILED]++; - $state->[STATE_PASSING] = 0; - } - } - elsif (!$self->[NO_HEADER] && $e->isa('Test::Stream::Event::Finish')) { - $state->[STATE_ENDED] = $e->context->snapshot; - - my $plan = $state->[STATE_PLAN]; - if ($plan && $e->tests_run && $plan->directive eq 'NO PLAN') { - $plan->set_max($state->[STATE_COUNT]); - $plan->set_directive(undef); - $cache->{tap_event} = $plan; - $cache->{do_tap} = 1; - } - else { - $cache->{do_tap} = 0; - $cache->{no_out} = 1; - } - } - elsif ($self->[NO_DIAG] && $e->isa('Test::Stream::Event::Diag')) { - $cache->{no_out} = 1; - } - elsif ($e->isa('Test::Stream::Event::Plan')) { - $cache->{is_plan} = 1; - - if($self->[NO_HEADER]) { - $cache->{no_out} = 1; - } - elsif(my $existing = $state->[STATE_PLAN]) { - my $directive = $existing ? $existing->directive : ''; - - if ($existing && (!$directive || $directive eq 'NO PLAN')) { - my ($p1, $f1, $l1) = $existing->context->call; - my ($p2, $f2, $l2) = $e->context->call; - die "Tried to plan twice!\n $f1 line $l1\n $f2 line $l2\n"; - } - } - - my $directive = $e->directive; - $cache->{no_out} = 1 if $directive && $directive eq 'NO PLAN'; - } - - push @{$state->[STATE_LEGACY]} => $e if $self->[USE_LEGACY]; - - $cache->{number} = $state->[STATE_COUNT]; - - return $cache; -} - -sub _process_event { - my ($self, $e, $cache) = @_; - - if ($self->[MUNGERS]) { - $_->($self, $e, $e->subevents) for @{$self->[MUNGERS]}; - } - - $self->_render_tap($cache) unless $cache->{no_out}; - - if ($self->[LISTENERS]) { - $_->($self, $e) for @{$self->[LISTENERS]}; - } -} - -sub _render_tap { - my ($self, $cache) = @_; - - return if $^C; - return unless $self->[USE_TAP]; - my $e = $cache->{tap_event}; - return unless $cache->{do_tap} || $e->can('to_tap'); - - my $num = $self->use_numbers ? $cache->{number} : undef; - my @sets = $e->to_tap($num); - - my $in_subtest = $e->in_subtest || 0; - my $indent = ' ' x $in_subtest; - - for my $set (@sets) { - my ($hid, $msg) = @$set; - next unless $msg; - my $enc = $e->encoding || confess "Could not find encoding!"; - my $io = $self->[IO_SETS]->{$enc}->[$hid] || confess "Could not find IO $hid for $enc"; - - local($\, $", $,) = (undef, ' ', ''); - $msg =~ s/^/$indent/mg if $in_subtest; - print $io $msg; - } -} - -sub _scan_for_begin { - my ($stop_at) = @_; - my $level = 2; - - while (my @call = caller($level++)) { - return 1 if $call[3] =~ m/::BEGIN$/; - return 0 if $call[3] eq $stop_at; - } - - return undef; -} - -sub _finalize_event { - my ($self, $e, $cache) = @_; - - if ($cache->{is_plan}) { - $cache->{state}->[STATE_PLAN] = $e; - return unless $e->directive; - return unless $e->directive eq 'SKIP'; - - my $subtest = @{$self->[SUBTESTS]}; - - $self->[SUBTESTS]->[-1]->{early_return} = $e if $subtest; - - if ($subtest) { - my $begin = _scan_for_begin('Test::Stream::Subtest::subtest'); - - if ($begin) { - warn "SKIP_ALL in subtest via 'BEGIN' or 'use', using exception for flow control\n"; - die $e; - } - elsif(defined $begin) { - no warnings 'exiting'; - eval { last TEST_STREAM_SUBTEST }; - warn "SKIP_ALL in subtest flow control error: $@"; - warn "Falling back to using an exception.\n"; - die $e; - } - else { - warn "SKIP_ALL in subtest could not find flow-control label, using exception for flow control\n"; - die $e; - } - } - - die $e unless $self->[EXIT_ON_DISRUPTION]; - exit 0; - } - elsif (!$cache->{do_tap} && $e->isa('Test::Stream::Event::Bail')) { - $self->[BAILED_OUT] = $e; - $self->[NO_ENDING] = 1; - - my $subtest = @{$self->[SUBTESTS]}; - - $self->[SUBTESTS]->[-1]->{early_return} = $e if $subtest; - - if ($subtest) { - my $begin = _scan_for_begin('Test::Stream::Subtest::subtest'); - - if ($begin) { - warn "BAILOUT in subtest via 'BEGIN' or 'use', using exception for flow control.\n"; - die $e; - } - elsif(defined $begin) { - no warnings 'exiting'; - eval { last TEST_STREAM_SUBTEST }; - warn "BAILOUT in subtest flow control error: $@"; - warn "Falling back to using an exception.\n"; - die $e; - } - else { - warn "BAILOUT in subtest could not find flow-control label, using exception for flow control.\n"; - die $e; - } - } - - die $e unless $self->[EXIT_ON_DISRUPTION]; - exit 255; - } -} - -sub _reset { - my $self = shift; - - return unless $self->pid != $$ || $self->tid != get_tid(); - - $self->[PID] = $$; - $self->[TID] = get_tid(); - if (USE_THREADS || $self->[_USE_FORK]) { - $self->[_USE_FORK] = undef; - $self->use_fork; - } - $self->[STATE] = [[0, 0, undef, 1]]; -} - -sub CLONE { - for my $stream (_stack()) { - next unless defined $stream->pid; - next unless defined $stream->tid; - - next if $$ == $stream->pid && get_tid() == $stream->tid; - - $stream->[IN_SUBTHREAD] = 1; - } -} - -sub DESTROY { - my $self = shift; - - return if $self->in_subthread; - - my $dir = $self->[_USE_FORK] || return; - - return unless defined $self->pid; - return unless defined $self->tid; - - return unless $$ == $self->pid; - return unless get_tid() == $self->tid; - - if ($ENV{TEST_KEEP_TMP_DIR}) { - print STDERR "# Not removing temp dir: $dir\n"; - return; - } - - opendir(my $dh, $dir) || confess "Could not open temp dir! ($dir)"; - while(my $file = readdir($dh)) { - next if $file =~ m/^\.+$/; - die "Unculled event! You ran tests in a child process, but never pulled them in!\n" - if $file !~ m/\.complete$/; - unlink("$dir/$file") || confess "Could not unlink file: '$dir/$file'"; - } - closedir($dh); - rmdir($dir) || warn "Could not remove temp dir ($dir)"; -} - -sub STORABLE_freeze { - my ($self, $cloning) = @_; - return if $cloning; - return ($self); -} - -sub STORABLE_thaw { - my ($self, $cloning, @vals) = @_; - return if $cloning; - return Test::Stream->shared; -} - - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream - A modern infrastructure for testing. - -=head1 SYNOPSYS - - # Enables modern enhancements such as forking support and TAP encoding. - # Also turns off expensive legacy support. - use Test::Stream; - use Test::More; - - # ... Tests ... - - done_testing; - -=head1 FEATURES - -When you load Test::Stream inside your test file you prevent Test::More from -turning on some expensive legacy support. You will also get warnings if your -code, or any other code you load uses deprecated or discouraged practices. - -=head1 IMPORT ARGUMENTS - -Any import argument not recognised will be treated as an export, if it is not a -valid export an exception will be thrown. - -=over 4 - -=item '-internal' - -This argument, I, will prevent the import process from -turning on enhanced features. This is mainly for internal use (thus the name) -in order to access/load Test::Stream. - -=item subtest_tap => 'none' - -Do not show events within subtests, just the subtest result itself. - -=item subtest_tap => 'instant' - -Show events as they happen (this is how legacy Test::More worked). This is the -default. - -=item subtest_tap => 'delayed' - -Show events within subtest AFTER the subtest event itself is complete. - -=item subtest_tap => 'both' - -Show events as they happen, then also display them after. - -=item 'enable_fork' - -Turns on support for code that forks. This is not activated by default because -it adds ~30ms to the Test::More compile-time, which can really add up in large -test suites. Turn it on only when needed. - -=item 'utf8' - -Set the TAP encoding to utf8 - -=item encoding => '...' - -Set the TAP encoding. - -=back - -=head1 EXPORTS - -=head2 DEFAULT EXPORTS - -=over 4 - -=item tap_encoding( $ENCODING ) - -Set the tap encoding from this point on. - -=item cull - -Bring in results from child processes/threads. This is automatically done -whenever a context is obtained, but you may wish to do it on demand. - -=back - -=head2 CONSTANTS - -none of these are exported by default you must request them - -=over - -=item OUT_STD - -=item OUT_ERR - -=item OUT_TODO - -These are indexes of specific IO handles inside an IO set (each encoding has an -IO set). - -=item STATE_COUNT - -=item STATE_FAILED - -=item STATE_PLAN - -=item STATE_PASSING - -=item STATE_LEGACY - -=item STATE_ENDED - -These are indexes into the STATE array present in the stream. - -=back - -=head1 THE STREAM STACK AND METHODS - -At any point there can be any number of streams. Most streams will be present -in the stream stack. The stack is managed via a collection of class methods. -You can always access the "current" or "central" stream using -Test::Stream->shared. If you want your events to go where they are supposed to -then you should always send them to the shared stream. - -It is important to note that any toogle, control, listener, munger, etc. -applied to a stream will effect only that stream. Independant streams, streams -down the stack, and streams added later will not get any settings from other -stacks. Keep this in mind if you take it upon yourself to modify the stream -stack. - -=head2 TOGGLES AND CONTROLS - -=over 4 - -=item $stream->use_fork - -Turn on forking support (it cannot be turned off). - -=item $stream->set_subtest_tap_instant($bool) - -=item $bool = $stream->subtest_tap_instant - -Render subtest events as they happen. - -=item $stream->set_subtest_tap_delayed($bool) - -=item $bool = $stream->subtest_tap_delayed - -Render subtest events when printing the result of the subtest - -=item $stream->set_exit_on_disruption($bool) - -=item $bool = $stream->exit_on_disruption - -When true, skip_all and bailout will call exit. When false the bailout and -skip_all events will be thrown as exceptions. - -=item $stream->set_use_tap($bool) - -=item $bool = $stream->use_tap - -Turn TAP rendering on or off. - -=item $stream->set_use_legacy($bool) - -=item $bool = $stream->use_legacy - -Turn legacy result storing on and off. - -=item $stream->set_use_numbers($bool) - -=item $bool = $stream->use_numbers - -Turn test numbers on and off. - -=item $stash = $stream->subtest_start($name, %params) - -=item $stash = $stream->subtest_stop($name) - -These will push/pop new states and subtest stashes. - -B Also see the wrapper methods in -L. - -=back - -=head2 SENDING EVENTS - - Test::Stream->shared->send($event) - -The C method is used to issue an event to the stream. This method will -handle thread/fork sych, mungers, listeners, TAP output, etc. - -=head2 ALTERING EVENTS - - Test::Stream->shared->munge(sub { - my ($stream, $event) = @_; - - ... Modify the event object ... - - # return is ignored. - }); - -Mungers can never be removed once added. The return from a munger is ignored. -Any changes you wish to make to the object must be done directly by altering -it in place. The munger is called before the event is rendered as TAP, and -AFTER the event has made any necessary state changes. - -=head2 LISTENING FOR EVENTS - - Test::Stream->shared->listen(sub { - my ($stream, $event) = @_; - - ... do whatever you want with the event ... - - # return is ignored - }); - -Listeners can never be removed once added. The return from a listener is -ignored. Changing an event in a listener is not something you should ever do, -though no protections are in place to prevent it (this may change!). The -listeners are called AFTER the event has been rendered as TAP. - -=head2 POST-TEST BEHAVIORS - - Test::Stream->shared->follow_up(sub { - my ($context) = @_; - - ... do whatever you need to ... - - # Return is ignored - }); - -follow_up subs are called only once, when the stream recieves a finish event. There are 2 ways a finish event can occur: - -=over 4 - -=item done_testing - -A finish event is generated when you call done_testing. The finish event occurs -before the plan is output. - -=item EXIT MAGIC - -A finish event is generated when the Test::Stream END block is called, just -before cleanup. This event will not happen if it was already geenerated by a -call to done_testing. - -=back - -=head2 OTHER METHODS - -=over - -=item $stream->state - -Get the current state of the stream. The state is an array where specific -indexes have specific meanings. These indexes are managed via constants. - -=item $stream->plan - -Get the plan event, if a plan has been issued. - -=item $stream->count - -Get the test count so far. - -=item $stream->failed - -Get the number of failed tests so far. - -=item $stream->ended - -Get the context in which the tests ended, if they have ended. - -=item $stream->legacy - -Used internally to store events for legacy support. - -=item $stream->is_passing - -Check if the test is passing its plan. - -=item $stream->done_testing($context, $max) - -Tell the stream we are done testing. - -=item $stream->fork_cull - -Gather events from other threads/processes. - -=back - -=head2 STACK METHODS AND INTERCEPTING EVENTS - -=over 4 - -=item $stream = Test::Stream->shared - -Get the current shared stream. The shared stream is the stream at the top of -the stack. - -=item Test::Stream->clear - -Completely remove the stream stack. It is very unlikely you will ever want to -do this. - -=item ($new, $old) = Test::Stream->intercept_start($new) - -=item ($new, $old) = Test::Stream->intercept_start - -Push a new stream to the top of the stack. If you do not provide a stack a new -one will be created for you. If you have one created for you it will have the -following differences from a default stack: - - $new->set_exit_on_disruption(0); - $new->set_use_tap(0); - $new->set_use_legacy(0); - -=item Test::Stream->intercept_stop($top) - -Pop the stack, you must pass in the instance you expect to be popped, there -will be an exception if they do not match. - -=item Test::Stream->intercept(sub { ... }) - - Test::Stream->intercept(sub { - my ($new, $old) = @_; - - ... - }); - -Temporarily push a new stream to the top of the stack. The codeblock you pass -in will be run. Once your codelbock returns the stack will be popped and -restored to the previous state. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/API.pm b/cpan/Test-Simple/lib/Test/Stream/API.pm deleted file mode 100644 index 0253081ac1..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/API.pm +++ /dev/null @@ -1,696 +0,0 @@ -package Test::Stream::API; -use strict; -use warnings; - -use Test::Stream::Tester qw/intercept/; -use Test::Stream::Carp qw/croak confess/; -use Test::Stream::Meta qw/is_tester init_tester/; -use Test::Stream qw/cull tap_encoding OUT_STD OUT_ERR OUT_TODO/; - -use Test::Stream::Exporter qw/import exports export_to/; -exports qw{ - listen munge follow_up - enable_forking cull - peek_todo push_todo pop_todo set_todo inspect_todo - is_tester init_tester - is_modern set_modern - context peek_context clear_context set_context - intercept - state_count state_failed state_plan state_ended is_passing - current_stream - - disable_tap enable_tap subtest_tap_instant subtest_tap_delayed tap_encoding - enable_numbers disable_numbers set_tap_outputs get_tap_outputs -}; -Test::Stream::Exporter->cleanup(); - -BEGIN { - require Test::Stream::Context; - Test::Stream::Context->import(qw/context inspect_todo/); - *peek_context = \&Test::Stream::Context::peek; - *clear_context = \&Test::Stream::Context::clear; - *set_context = \&Test::Stream::Context::set; - *push_todo = \&Test::Stream::Context::push_todo; - *pop_todo = \&Test::Stream::Context::pop_todo; - *peek_todo = \&Test::Stream::Context::peek_todo; -} - -sub listen(&) { Test::Stream->shared->listen($_[0]) } -sub munge(&) { Test::Stream->shared->munge($_[0]) } -sub follow_up(&) { Test::Stream->shared->follow_up($_[0]) } -sub enable_forking { Test::Stream->shared->use_fork() } -sub disable_tap { Test::Stream->shared->set_use_tap(0) } -sub enable_tap { Test::Stream->shared->set_use_tap(1) } -sub enable_numbers { Test::Stream->shared->set_use_numbers(1) } -sub disable_numbers { Test::Stream->shared->set_use_numbers(0) } -sub current_stream { Test::Stream->shared() } -sub state_count { Test::Stream->shared->count() } -sub state_failed { Test::Stream->shared->failed() } -sub state_plan { Test::Stream->shared->plan() } -sub state_ended { Test::Stream->shared->ended() } -sub is_passing { Test::Stream->shared->is_passing } - -sub subtest_tap_instant { - Test::Stream->shared->set_subtest_tap_instant(1); - Test::Stream->shared->set_subtest_tap_delayed(0); -} - -sub subtest_tap_delayed { - Test::Stream->shared->set_subtest_tap_instant(0); - Test::Stream->shared->set_subtest_tap_delayed(1); -} - -sub is_modern { - my ($package) = @_; - my $meta = is_tester($package) || croak "'$package' is not a tester package"; - return $meta->modern ? 1 : 0; -} - -sub set_modern { - my $package = shift; - croak "set_modern takes a package and a value" unless @_; - my $value = shift; - my $meta = is_tester($package) || croak "'$package' is not a tester package"; - return $meta->set_modern($value); -} - -sub set_todo { - my ($pkg, $why) = @_; - my $meta = is_tester($pkg) || croak "'$pkg' is not a tester package"; - $meta->set_todo($why); -} - -sub set_tap_outputs { - my %params = @_; - my $encoding = delete $params{encoding} || 'legacy'; - my $std = delete $params{std}; - my $err = delete $params{err}; - my $todo = delete $params{todo}; - - my @bad = keys %params; - croak "set_tap_output does not recognise these keys: " . join ", ", @bad - if @bad; - - my $ioset = Test::Stream->shared->io_sets; - my $enc = $ioset->init_encoding($encoding); - - $enc->[OUT_STD] = $std if $std; - $enc->[OUT_ERR] = $err if $err; - $enc->[OUT_TODO] = $todo if $todo; - - return $enc; -} - -sub get_tap_outputs { - my ($enc) = @_; - my $set = Test::Stream->shared->io_sets->init_encoding($enc || 'legacy'); - return { - encoding => $enc || 'legacy', - std => $set->[0], - err => $set->[1], - todo => $set->[2], - }; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::API - Single point of access to Test::Stream extendability -features. - -=head1 DESCRIPTION - -There are times where you want to extend or alter the bahvior of a test file or -test suite. This module collects all the features and tools that -L offers for such actions. Everything in this file is accessible -in other places, but with less sugar coating. - -=head1 SYNOPSYS - -Nothing is exported by default, you must request it. - - use Test::Stream::API qw/ ... /; - -=head2 MODIFYING EVENTS - - use Test::Stream::API qw/ munge /; - - munge { - my ($stream, $event, @subevents) = @_; - - if($event->isa('Test::Stream::Diag')) { - $event->set_message( "KILROY WAS HERE: " . $event->message ); - } - }; - -=head2 REPLACING TAP WITH ALTERNATIVE OUTPUT - - use Test::Stream::API qw/ disable_tap listen /; - - disable_tap(); - - listen { - my $stream = shift; - my ($event, @subevents) = @_; - - # Tracking results in a db? - my $id = log_event_to_db($e); - log_subevent_to_db($id, $_) for @subevents; - } - -=head2 END OF TEST BEHAVIORS - - use Test::Stream::API qw/ follow_up is_passing /; - - follow_up { - my ($context) = @_; - - if (is_passing()) { - print "KILROY Says the test file passed!\n"; - } - else { - print "KILROY is not happy with you!\n"; - } - }; - -=head2 ENABLING FORKING SUPPORT - - use Test::More; - use Test::Stream::API qw/ enable_forking /; - - enable_forking(); - - # This all just works now! - my $pid = fork(); - if ($pid) { # Parent - ok(1, "From Parent"); - } - else { # child - ok(1, "From Child"); - exit 0; - } - - done_testing; - -B Result order between processes is not guarenteed, but the test number -is handled for you meaning you don't need to care. - -Results: - - ok 1 - From Child - ok 2 - From Parent - -Or: - - ok 1 - From Parent - ok 2 - From Child - -=head2 REDIRECTING TAP OUTPUT - -You may omit any arguments to leave a specific handle unchanged. It is not -possible to set a handle to undef or 0 or any other false value. - - use Test::Stream::API qw/ set_tap_outputs /; - - set_tap_outputs( - encoding => 'legacy', # Default, - std => $STD_IO_HANDLE, # equivilent to $TB->output() - err => $ERR_IO_HANDLE, # equivilent to $TB->failure_output() - todo => $TODO_IO_HANDLE, # equivilent to $TB->todo_output() - ); - -B Each encoding has independant filehandles. - -=head1 GENERATING EVENTS - -=head2 EASY WAY - -The best way to generate an event is through a L -object. All events have a method associated with them on the context object. -The method will be the last part of the evene package name lowercased, for -example L can be issued via C<< $context->ok(...) >>. - - use Test::Stream::API qw/ context /; - my $context = context(); - $context->EVENT_TYPE(...); - -The arguments to the event method are the values for event accessors in order, -excluding the C, C, and C arguments. For instance -here is how the Ok event is defined: - - package Test::Stream::Event::Ok; - use Test::Stream::Event( - accessors => [qw/real_bool name diag .../], - ... - ); - -This means that the C<< $context->ok >> method takes up to 5 arguments. The -first argument is a boolean true/false, the second is the name of the test, and -the third is an arrayref of diagnostics messages or -L objects. - - $context->ok($bool, $name, [$diag]); - -Here are the main event methods, as well as their standard arguments: - -=over 4 - -=item $context->ok($bool, $name, \@diag) - -Issue an L event. - -=item $context->diag($msg) - -Issue an L event. - -=item $context->note($msg) - -Issue an L event. - -=item $context->plan($max, $directive, $reason) - -Issue an L event. C<$max> is the number of expected -tests. C<$directive> is a plan directive such as 'no_plan' or 'skip_all'. -C<$reason> is the reason for the directive (only applicable to skip_all). - -=item $context->bail($reason) - -Issue an L event. - -=back - -=head2 HARD WAY - -This is not recommended, but it demonstrates just how much the context shortcut -methods do for you. - - # First make a context - my $context = Test::Stream::Context->new_from_pairs( - frame => ..., # Where to report errors - stream => ..., # Test::Stream object to use - encoding => ..., # encoding from test package meta-data - in_todo => ..., # Are we in a todo? - todo => ..., # Which todo message should be used? - modern => ..., # Is the test package modern? - pid => ..., # Current PID - skip => ..., # Are we inside a 'skip' state? - provider => ..., # What tool created the context? - ); - - # Make the event - my $ok = Test::Stream::Event::Ok->new_from_pairs( - # Should reflect where the event was produced, NOT WHERE ERRORS ARE REPORTED - created => [__PACKAGE__, __FILE__, __LINE__], - context => $context, # A context is required - in_subtest => 0, - - bool => $bool, - name => $name, - diag => \@diag, - ); - - # Send the event to the stream. - Test::Stream->shared->send($ok); - - -=head1 EXPORTED FUNCTIONS - -All of these are functions. These functions all effect the current-shared -L object only. - -=head2 EVENT MANAGEMENT - -These let you install a callback that is triggered for all primary events. The -first argument is the L object, the second is the primary -L, any additional arguments are subevents. All subevents -are L objects which are directly tied to the primary one. -The main example of a subevent is the failure L -object associated with a failed L, events within a -subtest are another example. - -=over 4 - -=item listen { my ($stream, $event, @subevents) = @_; ... } - -Listen callbacks happen just after TAP is rendered (or just after it would be -rendered if TAP is disabled). - -=item munge { my ($stream, $event, @subevents) = @_; ... } - -Muinspect_todonge callbacks happen just before TAP is rendered (or just before -it would be rendered if TAP is disabled). - -=back - -=head2 POST-TEST BEHAVIOR - -=over 4 - -=item follow_up { my ($context) = @_; ... } - -A followup callback allows you to install behavior that happens either when -C is called, or when the test file completes. - -B If done_testing is not used, the callback will happen in the -C block used by L to enact magic at the end of the -test. - -=back - -=head2 CONCURRENCY - -=over 4 - -=item enable_forking() - -Turns forking support on. This turns on a synchronization method that *just -works* when you fork inside a test. This must be turned on prior to any -forking. - -=item cull() - -This can only be called in the main process or thread. This is a way to -manually pull in results from other processes or threads. Typically this -happens automatically, but this allows you to ensure results have been gathered -by a specific point. - -=back - -=head2 CONTROL OVER TAP - -=over 4 - -=item enable_tap() - -Turn TAP on (on by default). - -=item disable_tap() - -Turn TAP off. - -=item enable_numbers() - -Show test numbers when rendering TAP. - -=item disable_numbers() - -Do not show test numbers when rendering TAP. - -=item subtest_tap_instant() - -This is the default way to render subtests: - - # Subtest: a_subtest - ok 1 - pass - 1..1 - ok 1 - a_subtest - -Using this will automatically turn off C - -=item subtest_tap_delayed() - -This is an alternative way to render subtests, this method waits until the -subtest is complete then renders it in a structured way: - - ok 1 - a_subtest { - ok 1 - pass - 1..1 - } - -Using this will automatically turn off C - -=item tap_encoding($ENCODING) - -This lets you change the encoding for TAP output. This only effects the current -test package. - -=item set_tap_outputs(encoding => 'legacy', std => $IO, err => $IO, todo => $IO) - -This lets you replace the filehandles used to output TAP for any specific -encoding. All fields are optional, any handles not specified will not be -changed. The C parameter defaults to 'legacy'. - -B The todo handle is used for failure output inside subtests where the -subtest was started already in todo. - -=item $hashref = get_tap_outputs($encoding) - -'legacy' is used when encoding is not specified. - -Returns a hashref with the output handles: - - { - encoding => $encoding, - std => $STD_HANDLE, - err => $ERR_HANDLE, - todo => $TODO_HANDLE, - } - -B The todo handle is used for failure output inside subtests where the -subtest was started already in todo. - -=back - -=head2 TEST PACKAGE METADATA - -=over 4 - -=item $bool = is_modern($package) - -Check if a test package has the 'modern' flag. - -B Throws an exception if C<$package> is not already a test package. - -=item set_modern($package, $value) - -Turn on the modern flag for the specified test package. - -B Throws an exception if C<$package> is not already a test package. - -=back - -=head2 TODO MANAGEMENT - -=over 4 - -=item push_todo($todo) - -=item $todo = pop_todo() - -=item $todo = peek_todo() - -These can be used to manipulate a global C state. When a true value is at -the top of the todo stack it will effect any events generated via an -L object. Typically all events are generated this way. - -=item set_todo($package, $todo) - -This lets you set the todo state for the specified test package. This will -throw an exception if the package is not a test package. - -=item $todo_hashref = inspect_todo($package) - -=item $todo_hashref = inspect_todo() - -This lets you inspect the TODO state. Optionally you can specify a package to -inspect. The return is a hashref with several keys: - - { - TODO => $TODO_STACK_ARRAYREF, - TB => $TEST_BUILDER_TODO_STATE, - META => $PACKAGE_METADATA_TODO_STATE, - PKG => $package::TODO, - } - -This lets you see what todo states are set where. This is primarily useful when -debugging to see why something is unexpectedly TODO, or when something is not -TODO despite expectations. - -=back - -=head2 TEST PACKAGE MANAGEMENT - -=over 4 - -=item $meta = is_tester($package) - -Check if a package is a tester, if it is the meta-object for the tester is -returned. - -=item $meta = init_tester($package) - -Set the package as a tester and return the meta-object. If the package is -already a tester it will return the existing meta-object. - -=back - -=head2 CONTEXTUAL INFORMATION - -=over 4 - -=item $context = context() - -=item $context = context($add_level) - -This will get the correct L object. This may be one that -was previously initialized, or it may generate a new one. Read the -L documentation for more info. - -Note, C assumes you are at the lowest level of your tool, and looks -at the current caller. If you need it to look further you can call it with a -numeric argument which is added to the level. To clarify, calling C -is the same as calling C. - -=item $stream = current_stream() - -This will return the current L Object. L objects -typically live on a global stack, the topmost item on the stack is the one that -is normally used. - -=back - -=head2 CAPTURING EVENTS - -=over 4 - -=item $events_arrayref = intercept { ... }; - -Any events generated inside the codeblock will be intercepted and returned. No -events within the block will go to the real L instance. - -B This comes from the L package which provides -addiitonal tools that are useful for testing/validating events. - -=back - -=head2 TEST STATE - -=over 4 - -=item $num = state_count() - -Check how many tests have been run. - -=item $num = state_failed() - -Check how many tests have failed. - -=item $plan_event = state_plan() - -Check if a plan has been issued, if so the L -instance will be returned. - -=item $bool = state_ended() - -True if the test is complete (after done_testing). - -=item $bool = is_passing() - -Check if the test state is passing. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Architecture.pod b/cpan/Test-Simple/lib/Test/Stream/Architecture.pod deleted file mode 100644 index 84aec128bf..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Architecture.pod +++ /dev/null @@ -1,453 +0,0 @@ -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Architecture - overview of how the Test-More dist works. - -=head1 DESCRIPTION - -This document explains the Test::More architecture from top to bottom. - -=head1 KEY COMPONENTS - -This is the list of primary components and their brief description, the most -critical ones will have more details in later sections. - -=over 4 - -=item Test::More - -=item Test::Simple - -These contain the public subroutines for anyone who wishes to write tests. - -=item Test::More::Tools - -All of the tools that L provided have been relocated into -L and refactored to make them generic and reusable. - -This means you can use them without inadvertently firing off events. In many -cases this is what tool builders actually want but instead they settle for -bumping C<$Level> and calling is(), like(), or ok() and producing extra -events. - -=item Test::Builder - -This was the B under-the-hood module for anyone who wished to write -a L-compatible test library. It still works and should be fully -functional and backwards compatible. It is, however, discouraged as it is -mostly a compatibility wrapper. - -=item Test::Stream - -This is the B heart and soul of the Test::* architecture. It is not the -primary interface that a unit-test author will use. This module is responsible -for collecting all events from all threads and processes and then forwarding -them to TAP and any other added listeners. - -=item Test::Stream::IOSets - -This manages the IO handles to which all TAP is sent. - -In the old days, L cloned STDERR and STDOUT and applied various -magic to them. - -This module provides that legacy support while also adding support for L -and other encodings. By default, all TAP goes to the 'legacy' outputs, which -mimick what Test::Builder has always done. The 'legacy' outputs are also -what get altered if someone uses the Coutput> interface. - -=item Test::Stream::Toolset - -This is the primary interface a test module author should use. It ties together -some key functions you should use. It provides 3 critical functions: - - is_tester($package) - - init_tester($package) - - my $ctx = context(); - -=item Test::Stream::Context - -A context is used to generate events in test functions. - -Once a context object is created (the normal way) it is remembered and -anything that requests a context object will obtain the same instance. - -After the context instance is destroyed (at end of your test function) it is -forgotten. The next test function to run must obtain a new context instance. - -=item Test::Stream::Event - -=item Test::Stream::Event::Ok - -=item Test::Stream::Event::Diag - -=item Test::Stream::Event::Note - -=item Test::Stream::Event::* - -All events generated by L and other test tools now boil down to a -proper object. All event subclasses must use L as a base. - -=item Test::Stream::ArrayBase - -This is the L of L. It is responsible for generating -accessors and similar work. Unlike Moose, it uses an arrayref as the -underlying object to improve performance. Performance was a real problem in -some early alphas and the speed gains from this decision are huge. - -=item Test::Stream::Tester - -This module can validate testing tools and their events. - -=back - -=head1 THE STREAM OBJECT - -=over 4 - -=item L - -=back - -=head2 HISTORY - -L was (and still is) a singleton. The singleton model was -chosen to solve the problem of synchronizing everything to a central location. -Ultimately, all test results needed to make their way to a central place that -could assign each test a number and create output in the correct order. - -The singleton model proved to be a major headache. - -Intercepting events typically meant replacing the singleton permanently -(L) or for a limited scope. Another option people took -(L) was to simply replace the IO handles -Test::Builder was tracking. - -Test::Builder did not provide any real mechanisms for altering events -before processing them, or for intercepting them before they were turned into -TAP. As a result many modules have monkeypatched Test::Builder, particularily -the C method. - -=head2 CURRENT DESIGN - -L unfortunately must still act as a singleton (mostly). This -time, the design put as little logic as possible into the singleton. - -=head3 RESPONSIBILITIES OF TEST::STREAM - -Test::Stream has 4 main jobs: - -=over 4 - -=item Collect events from all threads and processes into 1 place - - $stream->send($event); - -The send() method will ensure that the event gets to the right place, no -matter which thread or process your code is in. (Forking support must be turned -on. It is off by default). - -B This method is key to performance. C and everything it calls -must remain as lean and tight as possible. - -=item Provide a pre-output hook to alter events - - $stream->munge(sub { my ($stream, $event) = @_; ... }) - -C lets you modify events before they are turned into output. It cannot -remove the event, nor can it add events. Mungers are additive and proceessed -in the order they are added. - -There is not currently any way to remove a munger. - -B each munger is called in a loop in the C method, so keep them -as fast and small as possible. - -=item Forward all events to all listeners (including TAP output) - - $stream->listen(sub { my ($stream, $event) = @_; .... }) - -C adds a listener. All events that come from the stream object will -be sent to all listeners. - -There is not currently any way to remove a listener. - -B each listener is called in a loop in the C method, so keep -them as fast and small as possible. - -=item Maintaining the legacy exit behavior from Test::Builder - -This is sets C<$?> to the number of tests that failed (up to 255). It also -provides some other output such as when a test file is missing a plan. - -=back - -=head3 SEMI-SINGLETON MODEL - -L has a semi-singleton model. Instead of 1 singleton, it has a -singleton stack. Anything that wants to send an event to the B acting -stream should send it to the stream returned by Cshared>. -Nothing should ever cache this result as the B stream may change. - -This mechanism is primarily used for intercepting and hiding all events for a -limited scope. L uses this to push a stream onto the -stack so that events can be generated that do not go to the listeners or TAP. -Once the stack is popped, the previous stream is restored, which allows real -events to be generated. - -You can also create new Test::Stream objects at-will that are not present in -the stack. This lets you create alternate streams for any purpose you want. - -=head1 THE CONTEXT OBJECT - -=over 4 - -=item L - -=back - -This module is responsible for 2 things: knowing where to report errors and -making it easy to issue events. - -=head2 ERROR REPORTING - -Use the C function to get the current context. - - sub ok { - my $context = context(); - ... - } - - ok() # Errors are reported here. - -If there is a context already in play, that instance will be returned. -Otherwise, a new context will be returned. - -The context assumes that the stack level just above your call is where errors -should be reported. - -You can optionally provide an integer as the only argument, in which case that -number will be added to the C call to find the correct frame for -reporting. - -B The integer argument will be completely ignored if there is already -an active context. - - sub ok { - my $context = context(); - ... - } - - sub my_ok { - my $context = context(); - ok(...); - } - - my_ok(); - -In the example above, c generates a new context and then it calls -C. In this case, both functions will have the same context object (the -one generated by C). The result is that C will report errors to -the correct place. - -=head3 IMPLEMENTATION - -There is a lexical variable C<$CURRENT> in C that can -not be directly touched. When the C function is called, it first -checks if $CURRENT is set, and if so, returns that. If there is no current -context, it generates a new one. - -When a new context is generated, it is assigned to C<$CURRENT>, but then the -reference is weakened. This means that once the returned copy falls out of -scope, or is otherwise removed, C<$CURRENT> will vanish on its own. This means -that so long as you hold on to your context object, anything you call will find -it. - -B here is that if you decide to hold on to your context beyond -your scope, you could sabatoge any future test functions. If you need to hold -on to a context you need to call C<$context-Esnapshot>, and store the -cloned object it returns. In general you should not need to do this. Event -objects all store the context but do so using a snapshot. - -B I am open to changing this to remove the weak-reference magic and -instead require someone to call C<$context-Erelease> or similar when they -are done with a context but that seems more likely to result in rogue -contexts. This method would also require its own form of reference counting. -This decision will need to be made before we go stable. - -=head2 GENERATING EVENTS - -All event subclasses should use L to set them up as -proper event objects. They should also add a method to -L to be used as a shortcut for generating that event -type. That will let you can fire off an event directly from your context -object using the lowercase name of the event class. - - my $ctx = context; - $ctx->ok(1, "pass"); - $ctx->ok(0, "fail, ["This test failed, here is some diag ..."]); - $ctx->note("I am a teapot"); - -All events take a context and 2 other arguments as the first 3 arguments of -their constructor, these shortcut methods handle those first 3 arguments for -you, making life much easier. - -The other arguments are: - -=over 4 - -=item created - -an arrayref with caller information for where the event was generated. - -=item in_subtest - -True if the event belongs in a subtest, false otherwise. - -=back - -=head1 EVENT OBJECTS - -Here are the primary public events. There are other events, but they are used -internally. - -=over 4 - -=item L - -This is just a base class. Do not use it directly. - -=item L - -=item L - -=item L - -=item L - -These are fairly simple and obvious event types. - -=item L - -=item L - -B C is a subclass of C. - -C can contain diag objects related to that specific ok. C -contains all the events that went into the final subtest result. - -=back - -All events have the context in which they were created, which includes the -file and line number where errors should be reported. They also have details -on where and how they were generated. All other details are event-specific. - -The subclass event should never be generated on its own. In fact, just use the -subtest helpers provided by L, or L. Under -the hood, a L event is started which adds a subtest to a stack in -Test::Stream, and then all events get intercepted by that subtest. When the -subtest is done, issue another Child event to close it out. Once closed, a -Subtest event will be generated for you and sent to the stream. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm b/cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm deleted file mode 100644 index 6ac75de373..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm +++ /dev/null @@ -1,373 +0,0 @@ -package Test::Stream::ArrayBase; -use strict; -use warnings; - -use Test::Stream::ArrayBase::Meta; -use Test::Stream::Carp qw/confess croak/; -use Scalar::Util qw/blessed reftype/; - -use Test::Stream::Exporter(); - -sub import { - my $class = shift; - my $caller = caller; - - $class->apply_to($caller, @_); -} - -sub apply_to { - my $class = shift; - my ($caller, %args) = @_; - - # Make the calling class an exporter. - my $exp_meta = Test::Stream::Exporter::Meta->new($caller); - Test::Stream::Exporter->export_to($caller, 'import') - unless $args{no_import}; - - my $ab_meta = Test::Stream::ArrayBase::Meta->new($caller); - - my $ISA = do { no strict 'refs'; \@{"$caller\::ISA"} }; - - if ($args{base}) { - my ($base) = grep { $_->isa($class) } @$ISA; - - croak "$caller is already a subclass of '$base', cannot subclass $args{base}" - if $base; - - my $file = $args{base}; - $file =~ s{::}{/}g; - $file .= ".pm"; - require $file unless $INC{$file}; - - my $pmeta = Test::Stream::ArrayBase::Meta->get($args{base}); - croak "Base class '$args{base}' is not a subclass of $class!" - unless $pmeta; - - push @$ISA => $args{base}; - - $ab_meta->subclass($args{base}); - } - elsif( !grep { $_->isa($class) } @$ISA) { - push @$ISA => $class; - $ab_meta->baseclass(); - } - - $ab_meta->add_accessors(@{$args{accessors}}) - if $args{accessors}; -} - -sub new { - my $class = shift; - my $self = bless [@_], $class; - $self->init if $self->can('init'); - return $self; -} - -sub new_from_pairs { - my $class = shift; - my %params = @_; - my $self = bless [], $class; - - while (my ($k, $v) = each %params) { - my $const = uc($k); - croak "$class has no accessor named '$k'" unless $class->can($const); - my $id = $class->$const; - $self->[$id] = $v; - } - - $self->init if $self->can('init'); - return $self; -} - -sub to_hash { - my $array_obj = shift; - my $meta = Test::Stream::ArrayBase::Meta->get(blessed $array_obj); - my $fields = $meta->fields; - my %out; - for my $f (keys %$fields) { - my $i = $fields->{$f}; - my $val = $array_obj->[$i]; - my $ao = blessed($val) && $val->isa(__PACKAGE__); - $out{$f} = $ao ? $val->to_hash : $val; - } - return \%out; -}; - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::ArrayBase - Base class for classes that use an arrayref instead -of a hash. - -=head1 SYNOPSYS - -A class: - - package My::Class; - use strict; - use warnings; - - use Test::Stream::ArrayBase accessors => [qw/foo bar baz/]; - - # Chance to initialize defaults - sub init { - my $self = shift; # No other args - $self->[FOO] ||= "foo"; - $self->[BAR] ||= "bar"; - $self->[BAZ] ||= "baz"; - } - - sub print { - print join ", " => map { $self->[$_] } FOO, BAR, BAZ; - } - -Subclass it - - package My::Subclass; - use strict; - use warnings; - use Test::Stream::ArrayBase base => 'My::Class', # subclass - accessors => ['bat']; - - sub init { - my $self = shift; - - # We get the constants from the base class for free. - $self->[FOO] ||= 'SubFoo'; - $self->[BAT] || = 'bat'; - - $self->SUPER::init(); - } - -use it: - - package main; - use strict; - use warnings; - use My::Class; - - my $one = My::Class->new('MyFoo', 'MyBar'); - - # Accessors! - my $foo = $one->foo; # 'MyFoo' - my $bar = $one->bar; # 'MyBar' - my $baz = $one->baz; # Defaulted to: 'baz' - - # Setters! - $one->set_foo('A Foo'); - $one->set_bar('A Bar'); - $one->set_baz('A Baz'); - - # It is an arrayref, you can do this! - my ($foo, $bar, $baz) = @$one; - - # import constants: - use My::Class qw/FOO BAR BAZ/; - - $one->[FOO] = 'xxx'; - -=head1 DESCRIPTION - -This package is used to generate classes based on arrays instead of hashes. The -primary motivation for this is performance (not premature!). Using this class -will give you a C method, as well as generating accessors you request. -Generated accessors will be getters, C setters will also be -generated for you. You also get constants for each accessor (all caps) which -return the index into the array for that accessor. Single inheritence is also -supported. For obvious reasons you cannot use multiple inheritence with an -array based object. - -=head1 METHODS - -=head2 PROVIDED BY ARRAY BASE - -=over 4 - -=item $it = $class->new(@VALUES) - -Create a new instance from a list of ordered values. - -=item $it = $class->new_from_pairs(%ACCESSOR_VAL_PAIRS) - -Create a new instance using key/value pairs. - -=item $hr = $it->to_hash() - -Get a hashref dump of the object. This will also dump any ArrayBase objects -within to a hash, but only surface-depth ones. - -=item $it->import() - -This import method is actually provided by L and allows -you to import the constants generated for you. - -=back - -=head2 HOOKS - -=over 4 - -=item $self->init() - -This gives you the chance to set some default values to your fields. The only -argument is C<$self> with its indexes already set from the constructor. - -=back - -=head1 ACCESSORS - -To generate accessors you list them when using the module: - - use Test::Stream::ArrayBase accessors => [qw/foo/]; - -This will generate the following subs in your namespace: - -=over 4 - -=item import() - -This will let you import the constants - -=item foo() - -Getter, used to get the value of the C field. - -=item set_foo() - -Setter, used to set the value of the C field. - -=item FOO() - -Constant, returs the field C's index into the class arrayref. This -function is also exported, but only when requested. Subclasses will also get -this function as a constant, not simply a method, that means it is copied into -the subclass namespace. - -=back - -=head1 SUBCLASSING - -You can subclass an existing ArrayBase class. - - use Test::Stream::ArrayBase - base => 'Another::ArrayBase::Class', - accessors => [qw/foo bar baz/], - -Once an ArrayBase class is used as a subclass it is locked and no new fields -can be added. All fields in any subclass will start at the next index after the -last field of the parent. All constants from base classes are added to -subclasses automatically. - -=head1 WHY? - -Switching to an arrayref base has resulted in significant performance boosts. - -When Test::Builder was initially refactored to support events, it was slow -beyond reason. A large part of the slowdown was due to the use of proper -methods instead of directly accessing elements. We also switched to using a LOT -more objects that have methods. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm b/cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm deleted file mode 100644 index 159807cc93..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm +++ /dev/null @@ -1,284 +0,0 @@ -package Test::Stream::ArrayBase::Meta; -use strict; -use warnings; - -use Test::Stream::Carp qw/confess/; - -my %META; - -sub package { shift->{package} } -sub parent { shift->{parent} } -sub locked { shift->{locked} } -sub fields {({ %{shift->{fields}} })} - -sub new { - my $class = shift; - my ($pkg) = @_; - - $META{$pkg} ||= bless { - package => $pkg, - locked => 0, - }, $class; - - return $META{$pkg}; -} - -sub get { - my $class = shift; - my ($pkg) = @_; - - return $META{$pkg}; -} - -sub baseclass { - my $self = shift; - $self->{parent} = 'Test::Stream::ArrayBase'; - $self->{index} = 0; - $self->{fields} = {}; -} - -sub subclass { - my $self = shift; - my ($parent) = @_; - confess "Already a subclass of $self->{parent}! Tried to sublcass $parent" if $self->{parent}; - - my $pmeta = $self->get($parent) || die "$parent is not an ArrayBase object!"; - $pmeta->{locked} = 1; - - $self->{parent} = $parent; - $self->{index} = $pmeta->{index}; - $self->{fields} = $pmeta->fields; #Makes a copy - - my $ex_meta = Test::Stream::Exporter::Meta->get($self->{package}); - - # Put parent constants into the subclass - for my $field (keys %{$self->{fields}}) { - my $const = uc $field; - no strict 'refs'; - *{"$self->{package}\::$const"} = $parent->can($const) || confess "Could not find constant '$const'!"; - $ex_meta->add($const); - } -} - -my $IDX = -1; -my (@CONST, @GET, @SET); -_GROW(20); - -sub _GROW { - my ($max) = @_; - return if $max <= $IDX; - for (($IDX + 1) .. $max) { - # Var per sub for inlining/constant stuff. - my $c = $_; - my $gi = $_; - my $si = $_; - - $CONST[$_] = sub() { $c }; - $GET[$_] = sub { $_[0]->[$gi] }; - $SET[$_] = sub { $_[0]->[$si] = $_[1] }; - } - $IDX = $max; -} - -*add_accessor = \&add_accessors; -sub add_accessors { - my $self = shift; - - confess "Cannot add accessor, metadata is locked due to a subclass being initialized ($self->{parent}).\n" - if $self->{locked}; - - my $ex_meta = Test::Stream::Exporter::Meta->get($self->{package}); - - for my $name (@_) { - confess "field '$name' already defined!" - if exists $self->{fields}->{$name}; - - my $idx = $self->{index}++; - $self->{fields}->{$name} = $idx; - - _GROW($IDX + 10) if $idx > $IDX; - - my $const = uc $name; - my $gname = lc $name; - my $sname = "set_$gname"; - - { - no strict 'refs'; - *{"$self->{package}\::$const"} = $CONST[$idx]; - *{"$self->{package}\::$gname"} = $GET[$idx]; - *{"$self->{package}\::$sname"} = $SET[$idx]; - } - - $ex_meta->{exports}->{$const} = $CONST[$idx]; - push @{$ex_meta->{polist}} => $const; - } -} - - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::ArrayBase::Meta - Meta Object for ArrayBase objects. - -=head1 SYNOPSYS - -B You probably do not want to directly use this object. - - my $meta = Test::Stream::ArrayBase::Meta->new('Some::Class'); - $meta->add_accessor('foo'); - -=head1 DESCRIPTION - -This is the meta-object used by L - -=head1 METHODS - -=over 4 - -=item $meta = $class->new($package) - -Create a new meta object for the specified class. If one already exists that -instance is returned. - -=item $meta = $class->get($package) - -Get the meta object for the specified class. Returns C if there is none -initiated. - -=item $package = $meta->package - -Get the package the meta-object manages. - -=item $package = $meta->parent - -Get the parent package to the one being managed. - -=item $bool = $meta->locked - -True if the package has been locked. Locked means no new accessors can be -added. A package is locked once something else subclasses it. - -=item $hr = $meta->fields - -Get a hashref defining the fields on the package. This is primarily for -internal use, it is not very useful outside. - -=item $meta->baseclass - -Make the package inherit from ArrayBase directly. - -=item $meta->subclass($package) - -Set C<$package> as the base class of the managed package. - -=item $meta->add_accessor($name) - -Add an accessor to the package. Also defines the C<"set_$name"> method, and the -C constant. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Block.pm b/cpan/Test-Simple/lib/Test/Stream/Block.pm deleted file mode 100644 index 7f6bd68365..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Block.pm +++ /dev/null @@ -1,205 +0,0 @@ -package Test::Stream::Block; -use strict; -use warnings; - -use Scalar::Util qw/blessed reftype/; -use Test::Stream::Carp qw/confess carp/; - -use Test::Stream::ArrayBase( - accessors => [qw/name coderef params caller deduced _start_line _end_line/], -); - -our %SUB_MAPS; - -sub PACKAGE() { 0 }; -sub FILE() { 1 }; -sub LINE() { 2 }; -sub SUBNAME() { 3 }; - -sub init { - my $self = shift; - - confess "coderef is a mandatory field for " . blessed($self) . " instances" - unless $self->[CODEREF]; - - confess "caller is a mandatory field for " . blessed($self) . " instances" - unless $self->[CALLER]; - - confess "coderef must be a code reference" - unless ref($self->[CODEREF]) && reftype($self->[CODEREF]) eq 'CODE'; - - $self->deduce; - - $self->[PARAMS] ||= {}; -} - -sub deduce { - my $self = shift; - - eval { require B; 1 } || return; - - my $code = $self->[CODEREF]; - my $cobj = B::svref_2object($code); - my $pkg = $cobj->GV->STASH->NAME; - my $file = $cobj->FILE; - my $line = $cobj->START->line; - my $subname = $cobj->GV->NAME; - - $SUB_MAPS{$file}->{$line} = $self->[NAME]; - - $self->[DEDUCED] = [$pkg, $file, $line, $subname]; - $self->[NAME] ||= $subname; -} - -sub merge_params { - my $self = shift; - my ($new) = @_; - my $old = $self->[PARAMS]; - - # Use existing ref, merge in new ones, but old ones are kept since the - # block can override the workflow. - %$old = ( %$new, %$old ); -} - -sub package { $_[0]->[DEDUCED]->[PACKAGE] } -sub file { $_[0]->[DEDUCED]->[FILE] } -sub subname { $_[0]->[DEDUCED]->[SUBNAME] } - -sub run { - my $self = shift; - my @args = @_; - - $self->[CODEREF]->(@args); -} - -sub detail { - my $self = shift; - - my $name = $self->[NAME]; - my $file = $self->file; - - my $start = $self->start_line; - my $end = $self->end_line; - - my $lines; - if ($end && $end != $start) { - $lines = "lines $start -> $end"; - } - elsif ($end) { - $lines = "line $start"; - } - else { - my ($dpkg, $dfile, $dline) = @{$self->caller}; - $lines = "line $start (declared in $dfile line $dline)"; - } - - my $known = ""; - if ($self->[DEDUCED]->[SUBNAME] ne '__ANON__') { - $known = " (" . $self->[DEDUCED]->[SUBNAME] . ")"; - } - - return "${name}${known} in ${file} ${lines}"; -} - -sub start_line { - my $self = shift; - return $self->[_START_LINE] if $self->[_START_LINE]; - - my $start = $self->[DEDUCED]->[LINE]; - my $end = $self->end_line || 0; - - if ($start == $end || $start == 1) { - $self->[_START_LINE] = $start; - } - else { - $self->[_START_LINE] = $start - 1; - } - - return $self->[_START_LINE]; -} - -sub end_line { - my $self = shift; - return $self->[_END_LINE] if $self->[_END_LINE]; - - my $call = $self->[CALLER]; - my $dedu = $self->[DEDUCED]; - - _map_package_file($dedu->[PACKAGE], $dedu->[FILE]); - - # Check if caller and deduced seem to be from the same place. - my $match = $call->[PACKAGE] eq $dedu->[PACKAGE]; - $match &&= $call->[FILE] eq $dedu->[FILE]; - $match &&= $call->[LINE] >= $dedu->[LINE]; - $match &&= !_check_interrupt($dedu->[FILE], $dedu->[LINE], $call->[LINE]); - - if ($match) { - $self->[_END_LINE] = $call->[LINE]; - return $call->[LINE]; - } - - # Uhg, see if we can figure it out. - my @lines = sort { $a <=> $b } keys %{$SUB_MAPS{$dedu->[FILE]}}; - for my $line (@lines) { - next if $line <= $dedu->[LINE]; - $self->[_END_LINE] = $line; - $self->[_END_LINE] -= 2 unless $SUB_MAPS{$dedu->[FILE]}->{$line} eq '__EOF__'; - return $self->[_END_LINE]; - } - - return undef; -} - -sub _check_interrupt { - my ($file, $start, $end) = @_; - return 0 if $start == $end; - - my @lines = sort { $a <=> $b } keys %{$SUB_MAPS{$file}}; - - for my $line (@lines) { - next if $line <= $start; - return $line <= $end; - } - - return 0; -} - -my %MAPPED; -sub _map_package_file { - my ($pkg, $file) = @_; - - return if $MAPPED{$pkg}->{$file}++; - - require B; - - my %seen; - my @symbols = do { no strict 'refs'; %{"$pkg\::"} }; - for my $sym (@symbols) { - my $code = $pkg->can($sym) || next; - next if $seen{$code}++; - - my $cobj = B::svref_2object($code); - - # Skip imported subs - my $pname = $cobj->GV->STASH->NAME; - next unless $pname eq $pkg; - - my $f = $cobj->FILE; - next unless $f eq $file; - - # Skip XS/C Files - next if $file =~ m/\.c$/; - next if $file =~ m/\.xs$/; - - my $line = $cobj->START->line; - $SUB_MAPS{$file}->{$line} ||= $sym; - } - - if (open(my $fh, '<', $file)) { - my $length = () = <$fh>; - close($fh); - $SUB_MAPS{$file}->{$length} = '__EOF__'; - } -} - -1; diff --git a/cpan/Test-Simple/lib/Test/Stream/Carp.pm b/cpan/Test-Simple/lib/Test/Stream/Carp.pm deleted file mode 100644 index 6ec6a1512f..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Carp.pm +++ /dev/null @@ -1,144 +0,0 @@ -package Test::Stream::Carp; -use strict; -use warnings; - -use Test::Stream::Exporter; - -export croak => sub { require Carp; goto &Carp::croak }; -export confess => sub { require Carp; goto &Carp::confess }; -export cluck => sub { require Carp; goto &Carp::cluck }; -export carp => sub { require Carp; goto &Carp::carp }; - -Test::Stream::Exporter->cleanup; - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Carp - Delayed Carp loader. - -=head1 DESCRIPTION - -Use this package instead of L to avoid loading L until absolutely -necessary. This is used instead of Carp in L in order to avoid -loading modules that packages you test may need to load themselves. - -=head1 SUPPORTED EXPORTS - -See L for details on each of these functions. - -=over 4 - -=item croak - -=item confess - -=item cluck - -=item carp - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Context.pm b/cpan/Test-Simple/lib/Test/Stream/Context.pm deleted file mode 100644 index b4215dbdb2..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Context.pm +++ /dev/null @@ -1,731 +0,0 @@ -package Test::Stream::Context; -use strict; -use warnings; - -use Scalar::Util qw/blessed weaken/; - -use Test::Stream::Carp qw/confess/; - -use Test::Stream::Threads; -use Test::Stream::Event(); -use Test::Stream::Util qw/try translate_filename/; -use Test::Stream::Meta qw/init_tester is_tester/; - -use Test::Stream::ArrayBase( - accessors => [qw/frame stream encoding in_todo todo modern pid skip diag_todo provider monkeypatch_stash/], -); - -use Test::Stream::Exporter qw/import export_to default_exports exports/; -default_exports qw/context/; -exports qw/inspect_todo/; -Test::Stream::Exporter->cleanup(); - -{ - no warnings 'once'; - $Test::Builder::Level ||= 1; -} - -my @TODO; -my $CURRENT; - -sub from_end_block { 0 }; - -sub init { - $_[0]->[FRAME] ||= _find_context(1); # +1 for call to init - $_[0]->[STREAM] ||= Test::Stream->shared; - $_[0]->[ENCODING] ||= 'legacy'; - $_[0]->[PID] ||= $$; -} - -sub peek { $CURRENT } -sub clear { $CURRENT = undef } - -sub push_todo { push @TODO => pop @_ } -sub pop_todo { pop @TODO } -sub peek_todo { @TODO ? $TODO[-1] : undef } - -sub set { - $CURRENT = pop; - weaken($CURRENT); -} - -my $WARNED; -sub context { - my ($level, $stream) = @_; - # If the context has already been initialized we simply return it, we - # ignore any additional parameters as they no longer matter. The first - # thing to ask for a context wins, anything context aware that is called - # later MUST expect that it can get a context found by something down the - # stack. - if ($CURRENT) { - return $CURRENT unless $stream; - return $CURRENT if $stream == $CURRENT->[STREAM]; - } - - my $call = _find_context($level); - $call = _find_context_harder() unless $call; - my $pkg = $call->[0]; - - my $meta = is_tester($pkg) || _find_tester(); - - # Check if $TODO is set in the package, if not check if Test::Builder is - # loaded, and if so if it has Todo set. We check the element directly for - # performance. - my ($todo, $in_todo); - { - my $todo_pkg = $meta->[Test::Stream::Meta::PACKAGE]; - no strict 'refs'; - no warnings 'once'; - if (@TODO) { - $todo = $TODO[-1]; - $in_todo = 1; - } - elsif ($todo = $meta->[Test::Stream::Meta::TODO]) { - $in_todo = 1; - } - elsif ($todo = ${"$pkg\::TODO"}) { - $in_todo = 1; - } - elsif ($todo = ${"$todo_pkg\::TODO"}) { - $in_todo = 1; - } - elsif ($Test::Builder::Test && defined $Test::Builder::Test->{Todo}) { - $todo = $Test::Builder::Test->{Todo}; - $in_todo = 1; - } - else { - $in_todo = 0; - } - }; - - my ($ppkg, $pname); - if(my @provider = caller(1)) { - ($ppkg, $pname) = ($provider[3] =~ m/^(.*)::([^:]+)$/); - } - - # Uh-Oh! someone has replaced the singleton, that means they probably want - # everything to go through them... We can't do a whole lot about that, but - # we will use the singletons stream which should catch most use-cases. - if ($Test::Builder::_ORIG_Test && $Test::Builder::_ORIG_Test != $Test::Builder::Test) { - $stream ||= $Test::Builder::Test->{stream}; - - my $warn = $meta->[Test::Stream::Meta::MODERN] - && !$WARNED++; - - warn <<" EOT" if $warn; - - ******************************************************************************* - Something replaced the singleton \$Test::Builder::Test. - - The Test::Builder singleton is no longer the central place for all test - events. Please look at Test::Stream, and Test::Stream->intercept() to - accomplish the type of thing that was once done with the singleton. - - All attempts have been made to preserve compatability with older modules, - but if you experience broken behavior you may need to update your code. If - updating your code is not an option you will need to downgrade to a - Test::More prior to version 1.301001. Patches that restore compatability - without breaking necessary Test::Stream functionality will be gladly - accepted. - ******************************************************************************* - EOT - } - - $stream ||= $meta->[Test::Stream::Meta::STREAM] || Test::Stream->shared || confess "No Stream!?"; - if ((USE_THREADS || $stream->_use_fork) && ($stream->pid == $$ && $stream->tid == get_tid())) { - $stream->fork_cull(); - } - - my $encoding = $meta->[Test::Stream::Meta::ENCODING] || 'legacy'; - $call->[1] = translate_filename($encoding => $call->[1]) if $encoding ne 'legacy'; - - my $ctx = bless( - [ - $call, - $stream, - $encoding, - $in_todo, - $todo, - $meta->[Test::Stream::Meta::MODERN] || 0, - $$, - undef, - $in_todo, - [$ppkg, $pname] - ], - __PACKAGE__ - ); - - weaken($ctx->[STREAM]); - - return $ctx if $CURRENT; - - $CURRENT = $ctx; - weaken($CURRENT); - return $ctx; -} - -sub _find_context { - my ($add) = @_; - - $add ||= 0; - my $tb = $Test::Builder::Level - 1; - - # 0 - call to find_context - # 1 - call to context/new - # 2 - call to tool - my $level = 2 + $add + $tb; - my ($package, $file, $line, $subname) = caller($level); - - if ($package) { - while ($package eq 'Test::Builder') { - ($package, $file, $line, $subname) = caller(++$level); - } - } - else { - while (!$package) { - ($package, $file, $line, $subname) = caller(--$level); - } - } - - return unless $package; - - return [$package, $file, $line, $subname]; -} - -sub _find_context_harder { - my $level = 0; - my $fallback; - while(1) { - my ($pkg, $file, $line, $subname) = caller($level++); - $fallback ||= [$pkg, $file, $line, $subname] if $subname =~ m/::END$/; - next if $pkg =~ m/^Test::(Stream|Builder|More|Simple)(::.*)?$/; - return [$pkg, $file, $line, $subname]; - } - - return $fallback if $fallback; - return [ '', '', 0, '' ]; -} - -sub _find_tester { - my $level = 2; - while(1) { - my $pkg = caller($level++); - last unless $pkg; - my $meta = is_tester($pkg) || next; - return $meta; - } - - # find a .t file! - $level = 0; - while(1) { - my ($pkg, $file) = caller($level++); - last unless $pkg; - if ($file eq $0 && $file =~ m/\.t$/) { - return init_tester($pkg); - } - } - - return init_tester('main'); -} - -sub alert { - my $self = shift; - my ($msg) = @_; - - my @call = $self->call; - - warn "$msg at $call[1] line $call[2].\n"; -} - -sub throw { - my $self = shift; - my ($msg) = @_; - - my @call = $self->call; - - $CURRENT = undef if $CURRENT = $self; - - die "$msg at $call[1] line $call[2].\n"; -} - -sub call { @{$_[0]->[FRAME]} } - -sub package { $_[0]->[FRAME]->[0] } -sub file { $_[0]->[FRAME]->[1] } -sub line { $_[0]->[FRAME]->[2] } -sub subname { $_[0]->[FRAME]->[3] } - -sub snapshot { - return bless [@{$_[0]}], blessed($_[0]); -} - -sub send { - my $self = shift; - $self->[STREAM]->send(@_); -} - -sub subtest_start { - my $self = shift; - my ($name, %params) = @_; - - $params{parent_todo} ||= $self->in_todo; - - $self->clear; - my $todo = $self->hide_todo; - - my $st = $self->stream->subtest_start($name, todo_stash => $todo, %params); - return $st; -} - -sub subtest_stop { - my $self = shift; - my ($name) = @_; - - my $st = $self->stream->subtest_stop($name); - - $self->set; - $self->restore_todo($st->{todo_stash}); - - return $st; -} - -# Uhg.. support legacy monkeypatching -# If this is still here in 2020 I will be a sad panda. -{ - sub ok { - return _ok(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{ok} != \&Test::Builder::ok; - my $self = shift; - local $Test::Builder::CTX = $self; - my ($bool, $name, @stash) = @_; - push @{$self->[MONKEYPATCH_STASH]} => \@stash; - my $out = Test::Builder->new->ok($bool, $name); - return $out; - } - - sub _unwind_ok { - my $self = shift; - my ($bool, $name) = @_; - my $stash = pop @{$self->[MONKEYPATCH_STASH]}; - return $self->_ok($bool, $name, @$stash); - } - - sub note { - return _note(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{note} != \&Test::Builder::note; - local $Test::Builder::CTX = shift; - my $out = Test::Builder->new->note(@_); - return $out; - } - - sub diag { - return _diag(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{diag} != \&Test::Builder::diag; - local $Test::Builder::CTX = shift; - my $out = Test::Builder->new->diag(@_); - return $out; - } - - sub plan { - return _plan(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{plan} != \&Test::Builder::plan; - local $Test::Builder::CTX = shift; - my ($num, $dir, $arg) = @_; - $dir ||= 'tests'; - $dir = 'skip_all' if $dir eq 'SKIP'; - $dir = 'no_plan' if $dir eq 'NO PLAN'; - my $out = Test::Builder->new->plan($dir, $num || $arg || ()); - return $out; - } - - sub done_testing { - return $_[0]->stream->done_testing(@_) - unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{done_testing} != \&Test::Builder::done_testing; - - local $Test::Builder::CTX = shift; - my $out = Test::Builder->new->done_testing(@_); - return $out; - } -} - -my %EVENTS; -sub events { \%EVENTS } - -sub register_event { - my $class = shift; - my ($pkg, $name) = @_; - - my $real_name = lc($pkg); - $real_name =~ s/^.*:://g; - - $name ||= $real_name; - - confess "Method '$name' is already defined, event '$pkg' cannot get a context method!" - if $class->can($name); - - $EVENTS{$real_name} = $pkg; - - # Use a string eval so that we get a names sub instead of __ANON__ - local ($@, $!); - eval qq| - sub $name { - my \$self = shift; - my \@call = caller(0); - my \$encoding = \$self->[ENCODING]; - \$call[1] = translate_filename(\$encoding => \$call[1]) if \$encoding ne 'legacy'; - my \$e = '$pkg'->new(\$self->snapshot, [\@call[0 .. 4]], 0, \@_); - return \$self->stream->send(\$e); - }; - 1; - | || die $@; -} - -sub meta { is_tester($_[0]->[FRAME]->[0]) } - -sub inspect_todo { - my ($pkg) = @_; - my $meta = $pkg ? is_tester($pkg) : undef; - - no strict 'refs'; - return { - TODO => [@TODO], - $Test::Builder::Test ? (TB => $Test::Builder::Test->{Todo}) : (), - $meta ? (META => $meta->[Test::Stream::Meta::TODO]) : (), - $pkg ? (PKG => ${"$pkg\::TODO"}) : (), - }; -} - -sub hide_todo { - my $self = shift; - - my $pkg = $self->[FRAME]->[0]; - my $meta = is_tester($pkg); - - my $found = inspect_todo($pkg); - - @TODO = (); - $Test::Builder::Test->{Todo} = undef; - $meta->[Test::Stream::Meta::TODO] = undef; - { - no strict 'refs'; - no warnings 'once'; - ${"$pkg\::TODO"} = undef; - } - - return $found; -} - -sub restore_todo { - my $self = shift; - my ($found) = @_; - - my $pkg = $self->[FRAME]->[0]; - my $meta = is_tester($pkg); - - @TODO = @{$found->{TODO}}; - $Test::Builder::Test->{Todo} = $found->{TB}; - $meta->[Test::Stream::Meta::TODO] = $found->{META}; - { - no strict 'refs'; - no warnings 'once'; - ${"$pkg\::TODO"} = $found->{PKG}; - } - - my $found2 = inspect_todo($pkg); - - for my $k (qw/TB META PKG/) { - no warnings 'uninitialized'; - next if "$found->{$k}" eq "$found2->{$k}"; - die "INTERNAL ERROR: Mismatch! $k:\t$found->{$k}\n\t$found2->{$k}\n" - } - - return; -} - -sub DESTROY { 1 } - -our $AUTOLOAD; -sub AUTOLOAD { - my $class = blessed($_[0]) || $_[0] || confess $AUTOLOAD; - - my $name = $AUTOLOAD; - $name =~ s/^.*:://g; - - my $module = 'Test/Stream/Event/' . ucfirst(lc($name)) . '.pm'; - try { require $module }; - - my $sub = $class->can($name); - goto &$sub if $sub; - - my ($pkg, $file, $line) = caller; - - die qq{Can't locate object method "$name" via package "$class" at $file line $line.\n}; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Context - Object to represent a testing context. - -=head1 DESCRIPTION - -In testing it is important to have context. It is not helpful to simply say a -test failed, you want to know where it failed. This object is responsible for -tracking the context of each test that is run. It makes it possible to get the -file and line number where the failure occured .This object is also responsible -for generating almost all the events you will encounter. - -=head1 SYNOPSYS - - use Test::Stream::Context qw/context/; - - sub my_tool { - my $ctx = context(); - - # Generate an event. - $ctx->ok(1, "Pass!"); - } - - 1; - -=head1 EXPORTS - -=over 4 - -=item $ctx = context() - -This function is used to obtain a context. If there is already a context object -in scope this will return it, otherwise it will return a new one. - -It is important that you never store a context object in a variable from a -higher scope, a package variable, or an object attribute. The scope of a -context matters a lot. - -If you want to store a context for later reference use the C method -to get a clone of it that is safe to store anywhere. - -Note, C assumes you are at the lowest level of your tool, and looks -at the current caller. If you need it to look further you can call it with a -numeric argument which is added to the level. To clarify, calling C -is the same as calling C. - -=back - -=head1 METHODS - -=over 4 - -=item $ctx->alert($MESSAGE) - -This issues a warning at the calling context (filename and line number where -errors should be reported). - -=item $ctx->throw($MESSAGE) - -This throws an exception at the calling context (filename and line number where -errors should be reported). - -=item ($package, $file, $line, $subname) = $ctx->call() - -Get the caller details for the context. This is where errors should be -reported. - -=item $pkg = $ctx->package - -Get the context package. - -=item $file = $ctx->file - -Get the context filename. - -=item $line = $ctx->line - -Get the context line number. - -=item $subname = $ctx->subname - -Get the context subroutine name. - -=item $ctx_copy = $ctx->snapshot - -Get a copy of the context object that is safe to store for later reference. - -=item $ctx->send($event) - -Send an event to the correct L object. - -=item $ctx = $class->peek - -Get the current context object, if there is one. - -=back - -=head2 DANGEROUS ONES - -=over 4 - -=item $ctx->set - -=item $class->set($ctx) - -Set the context object as the current one, replacing any that might already be -current. - -=item $class->clear - -Unset the current context. - -=item $ctx->register_event($package) - -=item $ctx->register_event($package, $name) - -Register a new event type, creating the shortcut method to generate it. If -C<$name> is not provided it will be taken from the end of the package name, and -will be lowercased. - -=item $hr = $ctx->events - -Get the hashref that holds C<< (name => $package) >> pairs. This is the actual -ref used by the package, so please do not alter it. - -=item $stash = $ctx->hide_todo - -=item $ctx->restore_todo($stash) - -These are used to temporarily hide the TODO value in ALL places where it might -be found. The returned C<$stash> must be used to restore it later. - -=item $stash = $ctx->subtest_start($name, %params) - -=item $stash = $ctx->subtest_stop($name) - -Used to start and stop subtests in the test stream. The stash can be used to -configure and manipulate the subtest information. C will hide -the current TODO settings, and unset the current context. C will -restore the TODO and reset the context back to what it was. - -B to take the results in the stash and produce a -L event from them. - -B. - -=back - -=head2 CLASS METHODS - -B These can effect all test packages, if that is not what you want do not use them!. - -=over 4 - -=item $msg = Test::Stream::Context->push_todo($msg) - -=item $msg = Test::Stream::Context->pop_todo() - -=item $msg = Test::Stream::Context->peek_todo() - -These manage a global todo stack. Any new context created will check here first -for a TODO. Changing this will not effect any existing context instances. This -is a reliable way to set a global todo that effects any/all packages. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event.pm b/cpan/Test-Simple/lib/Test/Stream/Event.pm deleted file mode 100644 index 2080597ce3..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event.pm +++ /dev/null @@ -1,404 +0,0 @@ -package Test::Stream::Event; -use strict; -use warnings; - -use Scalar::Util qw/blessed/; -use Test::Stream::Carp qw/confess/; - -use Test::Stream::ArrayBase( - accessors => [qw/context created in_subtest/], - no_import => 1, -); - -sub import { - my $class = shift; - - # Import should only when event is imported, subclasses do not use this - # import. - return if $class ne __PACKAGE__; - - my $caller = caller; - my (%args) = @_; - - my $ctx_meth = delete $args{ctx_method}; - - require Test::Stream::Context; - require Test::Stream; - - # %args may override base - Test::Stream::ArrayBase->apply_to($caller, base => $class, %args); - Test::Stream::Context->register_event($caller, $ctx_meth); - Test::Stream::Exporter::export_to( - 'Test::Stream', - $caller, - qw/OUT_STD OUT_ERR OUT_TODO/, - ); -} - -sub init { - confess("No context provided!") unless $_[0]->[CONTEXT]; -} - -sub encoding { $_[0]->[CONTEXT]->encoding } - -sub extra_details {} - -sub summary { - my $self = shift; - my $type = blessed $self; - $type =~ s/^.*:://g; - - my $ctx = $self->context; - - my ($package, $file, $line) = $ctx->call; - my ($tool_pkg, $tool_name) = @{$ctx->provider}; - $tool_name =~ s/^\Q$tool_pkg\E:://; - - return ( - type => lc($type), - - $self->extra_details(), - - package => $package || undef, - file => $file, - line => $line, - - tool_package => $tool_pkg, - tool_name => $tool_name, - - encoding => $ctx->encoding || undef, - in_todo => $ctx->in_todo || 0, - todo => $ctx->todo || '', - pid => $ctx->pid || 0, - skip => $ctx->skip || '', - ); -} - -sub subevents { } - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event - Base class for events - -=head1 DESCRIPTION - -Base class for all event objects that get passed through -L. - -=head1 SYNOPSYS - - package Test::Stream::Event::MyEvent; - use strict; - use warnings; - - # This will make our class an event subclass, add the specified accessors, - # inject a helper method into the context objects, and add constants for - # all our fields, and fields we inherit. - use Test::Stream::Event( - accessors => [qw/foo bar baz/], - ctx_method => 'my_event', - ); - - # Chance to initialize some defaults - sub init { - my $self = shift; - # no other args in @_ - - $self->SUPER::init(); - - $self->set_foo('xxx') unless defined $self->foo; - - # Events are arrayrefs, all accessors have a constant defined with - # their index. - $self->[BAR] ||= ""; - - ... - } - - # If your event produces TAP output it must define this method - sub to_tap { - my $self = shift; - return ( - # Constants are defined at import, all are optional, and may appear - # any number of times. - [OUT_STD, $self->foo], - [OUT_ERR, $self->bar], - [OUT_STD, $self->baz], - ); - } - - # This is your hook to add details to the summary fields. - sub extra_details { - my $self = shift; - - my @super_details = $self->SUPER::extra_details(); - - return ( - @super_details, - - foo => $self->foo || undef, - bar => $self->bar || '', - ... - ); - } - - 1; - -=head1 IMPORTING - -=head2 ARGUMENTS - -In addition to the arguments listed here, you may pass in any arguments -accepted by L. - -=over 4 - -=item ctx_method => $NAME - -This specifies the name of the helper meth that will be injected into -L to help generate your events. If this is not specified -it will use the lowercased last section of your package name. - -=item base => $BASE_CLASS - -This lets you specify an event class to subclass. B. If you do not specify anything here then C will be -used. - -=item accessors => \@FIELDS - -This lets you define any fields you wish to be present in your class. This is -the only way to define storage for your event. Each field specified will get a -read-only accessor with the same name as the field, as well as a setter -C. You will also get a constant that returns the index of the -field in the classes arrayref. The constant is the name of the field in all -upper-case. - -=back - -=head2 SUBCLASSING - -C is added to your @INC for you, unless you specify an -alternative base class, which must itself subclass C. - -Events B use multiple inheritance in most cases. This is mainly -because events are arrayrefs and not hashrefs. Each subclass must add fields as -new indexes after the last index of the parent class. - -=head2 CONTEXT HELPER - -All events need some initial fields for construction. These fields include a -context, and some other state from construction time. The context object will -get helper methods for all events that fill in these fields for you. It is not -advised to ever construct an event object yourself, you should I use -the context helper method. - -=head1 EVENTS ARE ARRAY REFERENCES - -Events are an arrayref. Events use L under the hood to -generate accessors, constants, and field indexes. The key thing to take away -from this is that you cannot add attributes on the fly, you B use -L and/or L to add fields. - -If you need a place to store extar generic, and possibly unpredictable, data, -you should add a field and assign a hashref to it, then use that hashref to -store your mixed data. - -=head1 METHODS - -=over 4 - -=item $ctx = $e->context - -Get a snapshot of the context as it was when this event was generated - -=item $call = $e->created - -Get the C details from when the objects was created. This is usually -the call to the tool that generated the event such as C. - -=item $bool = $e->in_subtest - -Check if the event was generated within a subtest. - -=item $encoding = $e->encoding - -Get the encoding that was in effect when the event was generated - -=item @details = $e->extra_details - -Get an ordered key/value pair list of summary fields for the event. Override -this to add additional fields. - -=item @summary = $e->summary - -Get an ordered key/value pair list of summary fields for the event, including -parent class fields. In general you should not override this as it has a useful -(thought not depended upon) order. - -=back - -=head1 SUMMARY FIELDS - -These are the fields that will be present when calling -C<< my %sum = $e->summary >>. Please note that the fields are returned as an -order key+pair list, they can be directly assigned to a hash if desired, or -they can be assigned to an array to preserver the order. The order is as it -appears below, B alphabetical. - -=over 4 - -=item type - -The name of the event type, typically this is the lowercase form of the last -part of the class name. - -=item package - -The package that generated this event. - -=item file - -The file in which the event was generated, and to which errors should be attributed. - -=item line - -The line number on which the event was generated, and to which errors should be -attributed. - -=item tool_package - -The package that provided the tool that generated the event (example: -Test::More) - -=item tool_name - -The name of the sub that produced the event (examples: C, C). - -=item encoding - -The encoding that should be used when printing the TAP output from this event. - -=item in_todo - -True if the event was generated while TODO was in effect. - -=item todo - -The todo message if the event was generated with TODO in effect. - -=item pid - -The PID in which the event was generated. - -=item skip - -The skip message if the event was generated via skip. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm deleted file mode 100644 index 4b50c63f30..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm +++ /dev/null @@ -1,184 +0,0 @@ -package Test::Stream::Event::Bail; -use strict; -use warnings; - -use Test::Stream::Event( - accessors => [qw/reason quiet/], -); - -sub to_tap { - my $self = shift; - return if $self->[QUIET]; - return [ - OUT_STD, - "Bail out! " . $self->reason . "\n", - ]; -} - -sub extra_details { - my $self = shift; - return ( - $self->reason || '', - $self->quiet || 0, - ); -} - - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event::Bail - Bailout! - -=head1 DESCRIPTION - -The bailout event is generated when things go horribly wrong and you need to -halt all testing in the current file. - -=head1 SYNOPSYS - - use Test::Stream::Context qw/context/; - use Test::Stream::Event::Bail; - - my $ctx = context(); - my $event = $ctx->bail('Stuff is broken'); - -=head1 METHODS - -Inherits from L. Also defines: - -=over 4 - -=item $reason = $e->reason - -The reason for the bailout. - -=item $bool = quiet - -Should the bailout be quiet? - -=back - -=head1 SUMMARY FIELDS - -These are the fields that will be present when calling -C<< my %sum = $e->summary >>. Please note that the fields are returned as an -order key+pair list, they can be directly assigned to a hash if desired, or -they can be assigned to an array to preserver the order. The order is as it -appears below, B alphabetical. - -=over 4 - -=item reason - -Reason for the bailout - -=item quiet - -Boolean, true if the bailout should be quiet. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm deleted file mode 100644 index 365a9868cb..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm +++ /dev/null @@ -1,206 +0,0 @@ -package Test::Stream::Event::Diag; -use strict; -use warnings; - -use Test::Stream::Event( - accessors => [qw/message linked/], - ctx_method => '_diag', -); - -use Test::Stream::Util qw/try/; -use Scalar::Util qw/weaken/; -use Test::Stream::Carp qw/confess/; - -sub init { - $_[0]->SUPER::init(); - if (defined $_[0]->[MESSAGE]) { - $_[0]->[MESSAGE] .= ""; - } - else { - $_[0]->[MESSAGE] = 'undef'; - } - weaken($_[0]->[LINKED]) if $_[0]->[LINKED]; -} - -sub link { - my $self = shift; - my ($to) = @_; - confess "Already linked!" if $self->[LINKED]; - $self->[LINKED] = $to; - weaken($self->[LINKED]); -} - -sub to_tap { - my $self = shift; - - chomp(my $msg = $self->[MESSAGE]); - - $msg = "# $msg" unless $msg =~ m/^\n/; - $msg =~ s/\n/\n# /g; - - return [ - ($self->[CONTEXT]->diag_todo ? OUT_TODO : OUT_ERR), - "$msg\n", - ]; -} - -sub extra_details { - my $self = shift; - return ( message => $self->message || '' ); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event::Diag - Diag event type - -=head1 DESCRIPTION - -Diagnostics messages, typically rendered to STDERR. - -=head1 SYNOPSYS - - use Test::Stream::Context qw/context/; - use Test::Stream::Event::Diag; - - my $ctx = context(); - my $event = $ctx->diag($message); - -=head1 ACCESSORS - -=over 4 - -=item $diag->message - -The message for the diag. - -=item $diag->linked - -The Ok event the diag is linked to, if it is. - -=back - -=head1 METHODS - -=over 4 - -=item $diag->link($ok); - -Link the diag to an OK event. - -=back - -=head1 SUMMARY FIELDS - -=over 4 - -=item message - -The message from the diag. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm deleted file mode 100644 index 0617e5f72a..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm +++ /dev/null @@ -1,129 +0,0 @@ -package Test::Stream::Event::Finish; -use strict; -use warnings; - -use Test::Stream::Event( - accessors => [qw/tests_run tests_failed/], -); - -sub extra_details { - my $self = shift; - return ( - tests_run => $self->tests_run || 0, - tests_failed => $self->tests_failed || 0, - ); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event::Finish - The finish event type - -=head1 DESCRIPTION - -Sent after testing is finished. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm deleted file mode 100644 index 6d39548395..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm +++ /dev/null @@ -1,177 +0,0 @@ -package Test::Stream::Event::Note; -use strict; -use warnings; - -use Test::Stream::Event( - accessors => [qw/message/], - ctx_method => '_note', -); - -use Test::Stream::Carp qw/confess/; - -sub init { - $_[0]->SUPER::init(); - if (defined $_[0]->[MESSAGE]) { - $_[0]->[MESSAGE] .= ""; - } - else { - $_[0]->[MESSAGE] = 'undef'; - } -} - -sub to_tap { - my $self = shift; - - chomp(my $msg = $self->[MESSAGE]); - $msg = "# $msg" unless $msg =~ m/^\n/; - $msg =~ s/\n/\n# /g; - - return [OUT_STD, "$msg\n"]; -} - -sub extra_details { - my $self = shift; - return ( message => $self->message || '' ); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event::Note - Note event type - -=head1 DESCRIPTION - -Notes, typically rendered to STDOUT. - -=head1 SYNOPSYS - - use Test::Stream::Context qw/context/; - use Test::Stream::Event::Note; - - my $ctx = context(); - my $event = $ctx->Note($message); - -=head1 ACCESSORS - -=over 4 - -=item $note->message - -The message for the note. - -=back - -=head1 SUMMARY FIELDS - -=over 4 - -=item message - -The message from the note. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm deleted file mode 100644 index e4e9c03368..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm +++ /dev/null @@ -1,392 +0,0 @@ -package Test::Stream::Event::Ok; -use strict; -use warnings; - -use Scalar::Util qw/blessed/; -use Test::Stream::Util qw/unoverload_str/; -use Test::Stream::Carp qw/confess/; - -use Test::Stream::Event( - accessors => [qw/real_bool name diag bool level/], - ctx_method => '_ok', -); - -sub skip { $_[0]->[CONTEXT]->skip } -sub todo { $_[0]->[CONTEXT]->todo } - -sub init { - my $self = shift; - - $self->SUPER::init(); - - # Do not store objects here, only true/false/undef - if ($self->[REAL_BOOL]) { - $self->[REAL_BOOL] = 1; - } - elsif(defined $self->[REAL_BOOL]) { - $self->[REAL_BOOL] = 0; - } - $self->[LEVEL] = $Test::Builder::Level; - - my $ctx = $self->[CONTEXT]; - my $rb = $self->[REAL_BOOL]; - my $todo = $ctx->in_todo; - my $skip = defined $ctx->skip; - my $b = $rb || $todo || $skip || 0; - my $diag = delete $self->[DIAG]; - my $name = $self->[NAME]; - - $self->[BOOL] = $b ? 1 : 0; - - unless ($rb || ($todo && $skip)) { - my $msg = $todo ? "Failed (TODO)" : "Failed"; - my $prefix = $ENV{HARNESS_ACTIVE} ? "\n" : ""; - - my ($pkg, $file, $line) = $ctx->call; - - if (defined $name) { - $msg = qq[$prefix $msg test '$name'\n at $file line $line.]; - } - else { - $msg = qq[$prefix $msg test at $file line $line.]; - } - - $self->add_diag($msg); - } - - $self->add_diag(" You named your test '$name'. You shouldn't use numbers for your test names.\n Very confusing.") - if $name && $name =~ m/^[\d\s]+$/; - - $self->add_diag(@$diag) if $diag && @$diag; -} - -sub to_tap { - my $self = shift; - my ($num) = @_; - - my $name = $self->[NAME]; - my $context = $self->[CONTEXT]; - my $skip = $context->skip; - my $todo = $context->todo; - - my @out; - push @out => "not" unless $self->[REAL_BOOL]; - push @out => "ok"; - push @out => $num if defined $num; - - unoverload_str \$name if defined $name; - - if ($name) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - push @out => ("-", $name); - } - - if (defined $skip && defined $todo) { - push @out => "# TODO & SKIP"; - push @out => $todo if length $todo; - } - elsif ($context->in_todo) { - push @out => "# TODO"; - push @out => $todo if length $todo; - } - elsif (defined $skip) { - push @out => "# skip"; - push @out => $skip if length $skip; - } - - my $out = join " " => @out; - $out =~ s/\n/\n# /g; - - return [OUT_STD, "$out\n"] unless $self->[DIAG]; - - return ( - [OUT_STD, "$out\n"], - map {$_->to_tap($num)} @{$self->[DIAG]}, - ); -} - -sub add_diag { - my $self = shift; - - my $context = $self->[CONTEXT]; - my $created = $self->[CREATED]; - - for my $item (@_) { - next unless $item; - - if (ref $item) { - confess("Only diag objects can be linked to events.") - unless blessed($item) && $item->isa('Test::Stream::Event::Diag'); - - $item->link($self); - } - else { - $item = Test::Stream::Event::Diag->new($context, $created, $self->[IN_SUBTEST], $item, $self); - } - - push @{$self->[DIAG]} => $item; - } -} - -{ - # Yes, we do want to override the imported one. - no warnings 'redefine'; - sub clear_diag { - my $self = shift; - return unless $self->[DIAG]; - my $out = $self->[DIAG]; - $self->[DIAG] = undef; - $_->set_linked(undef) for @$out; - return $out; - } -} - -sub subevents { @{$_[0]->[DIAG] || []} } - -sub to_legacy { - my $self = shift; - - my $result = {}; - $result->{ok} = $self->bool ? 1 : 0; - $result->{actual_ok} = $self->real_bool; - $result->{name} = $self->name; - - my $ctx = $self->context; - - if($self->skip && ($ctx->in_todo || $ctx->todo)) { - $result->{type} = 'todo_skip', - $result->{reason} = $ctx->skip || $ctx->todo; - } - elsif($ctx->in_todo || $ctx->todo) { - $result->{reason} = $ctx->todo; - $result->{type} = 'todo'; - } - elsif($ctx->skip) { - $result->{reason} = $ctx->skip; - $result->{type} = 'skip'; - } - else { - $result->{reason} = ''; - $result->{type} = ''; - } - - if ($result->{reason} eq 'incrementing test number') { - $result->{type} = 'unknown'; - } - - return $result; -} - -sub extra_details { - my $self = shift; - - require Test::Stream::Tester::Events; - - my $diag = join "\n", map { - my $msg = $_->message; - chomp($msg); - split /[\n\r]+/, $msg; - } @{$self->diag || []}; - - return ( - diag => $diag || '', - bool => $self->bool || 0, - name => $self->name || undef, - real_bool => $self->real_bool || 0 - ); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event::Ok - Ok event type - -=head1 DESCRIPTION - -Ok events are generated whenever you run a test that produces a result. -Examples are C, and C. - -=head1 SYNOPSYS - - use Test::Stream::Context qw/context/; - use Test::Stream::Event::Ok; - - my $ctx = context(); - my $event = $ctx->ok($bool, $name, \@diag); - -=head1 ACCESSORS - -=over 4 - -=item $rb = $e->real_bool - -This is the true/false value of the test after TODO, SKIP, and similar -modifiers are taken into account. - -=item $name = $e->name - -Name of the test. - -=item $diag = $e->diag - -An arrayref with all the L events reduced down to -just the messages. Some coaxing has beeen done to combine all the messages into -a single string. - -=item $b = $e->bool - -The original true/false value of whatever was passed into the event (but -reduced down to 1 or 0). - -=item $l = $e->level - -For legacy L support. Do not use this, it can go away, or change -behavior at any time. - -=back - -=head1 METHODS - -=over 4 - -=item $le = $e->to_legacy - -Returns a hashref that matches some legacy details about ok's. You should -probably not use this for anything new. - -=item $e->add_diag($diag_event, "diag message" ...) - -Add a diag to the event. The diag may be a diag event, or a simple string. - -=item $diag = $e->clear_diag - -Remove all diag events, then return them in an arrayref. - -=back - -=head1 SUMMARY FIELDS - -=over 4 - -=item diag - -A single string with all the messages from the diags linked to the event. - -=item bool - -True/False passed into the test. - -=item name - -Name of the test. - -=item real_bool - -True/False value accounting for TODO and SKIP. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm deleted file mode 100644 index f3712b2ca5..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm +++ /dev/null @@ -1,221 +0,0 @@ -package Test::Stream::Event::Plan; -use strict; -use warnings; - -use Test::Stream::Event( - accessors => [qw/max directive reason/], - ctx_method => '_plan', -); - -use Test::Stream::Carp qw/confess/; - -my %ALLOWED = ( - 'SKIP' => 1, - 'NO PLAN' => 1, -); - -sub init { - $_[0]->SUPER::init(); - - if ($_[0]->[DIRECTIVE]) { - $_[0]->[DIRECTIVE] = 'SKIP' if $_[0]->[DIRECTIVE] eq 'skip_all'; - $_[0]->[DIRECTIVE] = 'NO PLAN' if $_[0]->[DIRECTIVE] eq 'no_plan'; - - confess "'" . $_[0]->[DIRECTIVE] . "' is not a valid plan directive" - unless $ALLOWED{$_[0]->[DIRECTIVE]}; - } - else { - $_[0]->[DIRECTIVE] = ''; - confess "Cannot have a reason without a directive!" - if defined $_[0]->[REASON]; - - confess "No number of tests specified" - unless defined $_[0]->[MAX]; - } -} - -sub to_tap { - my $self = shift; - - my $max = $self->[MAX]; - my $directive = $self->[DIRECTIVE]; - my $reason = $self->[REASON]; - - return if $directive && $directive eq 'NO PLAN'; - - my $plan = "1..$max"; - if ($directive) { - $plan .= " # $directive"; - $plan .= " $reason" if defined $reason; - } - - return [OUT_STD, "$plan\n"]; -} - -sub extra_details { - my $self = shift; - return ( - max => $self->max || 0, - directive => $self->directive || undef, - reason => $self->reason || undef - ); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event::Plan - The event of a plan - -=head1 DESCRIPTION - -Plan events are fired off whenever a plan is declared, done testing is called, -or a subtext completes. - -=head1 SYNOPSYS - - use Test::Stream::Context qw/context/; - use Test::Stream::Event::Plan; - - my $ctx = context(); - my $event = $ctx->plan($max, $directive, $reason); - -=head1 ACCESSORS - -=over 4 - -=item $num = $plan->max - -Get the number of expected tests - -=item $dir = $plan->directive - -Get the directive (such as TODO, skip_all, or no_plan). - -=item $reason = $plan->reason - -Get the reason for the directive. - -=back - -=head1 SUMMARY FIELDS - -=over 4 - -=item max - -Number of expected tests. - -=item directive - -Directive. - -=item reason - -Reason for directive. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm deleted file mode 100644 index 13ae97ef7d..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm +++ /dev/null @@ -1,297 +0,0 @@ -package Test::Stream::Event::Subtest; -use strict; -use warnings; - -use Scalar::Util qw/blessed/; -use Test::Stream::Carp qw/confess/; -use Test::Stream qw/-internal STATE_PASSING STATE_COUNT STATE_FAILED STATE_PLAN/; - -use Test::Stream::Event( - base => 'Test::Stream::Event::Ok', - accessors => [qw/state events exception early_return delayed instant/], -); - -sub init { - my $self = shift; - $self->[EVENTS] ||= []; - - $self->[REAL_BOOL] = $self->[STATE]->[STATE_PASSING] && $self->[STATE]->[STATE_COUNT]; - - if ($self->[EXCEPTION]) { - push @{$self->[DIAG]} => "Exception in subtest '$self->[NAME]': $self->[EXCEPTION]"; - $self->[STATE]->[STATE_PASSING] = 0; - $self->[BOOL] = 0; - $self->[REAL_BOOL] = 0; - } - - if (my $le = $self->[EARLY_RETURN]) { - my $is_skip = $le->isa('Test::Stream::Event::Plan'); - $is_skip &&= $le->directive; - $is_skip &&= $le->directive eq 'SKIP'; - - if ($is_skip) { - my $skip = $le->reason || "skip all"; - # Should be a snapshot now: - $self->[CONTEXT]->set_skip($skip); - $self->[REAL_BOOL] = 1; - } - else { # BAILOUT - $self->[REAL_BOOL] = 0; - } - } - - push @{$self->[DIAG]} => " No tests run for subtest." - unless $self->[EXCEPTION] || $self->[EARLY_RETURN] || $self->[STATE]->[STATE_COUNT]; - - # Have the 'OK' init run - $self->SUPER::init(); -} - -sub subevents { - return ( - @{$_[0]->[DIAG] || []}, - map { $_, $_->subevents } @{$_[0]->[EVENTS] || []}, - ); -} - -sub to_tap { - my $self = shift; - my ($num) = @_; - - my $delayed = $self->[DELAYED]; - - unless($delayed) { - return if $self->[EXCEPTION] - && $self->[EXCEPTION]->isa('Test::Stream::Event::Bail'); - - return $self->SUPER::to_tap($num); - } - - # Subtest final result first - $self->[NAME] =~ s/$/ {/mg; - my @out = ( - $self->SUPER::to_tap($num), - $self->_render_events($num), - [OUT_STD, "}\n"], - ); - $self->[NAME] =~ s/ \{$//mg; - return @out; -} - -sub _render_events { - my $self = shift; - my ($num) = @_; - - my $delayed = $self->[DELAYED]; - - my $idx = 0; - my @out; - for my $e (@{$self->events}) { - next unless $e->can('to_tap'); - $idx++ if $e->isa('Test::Stream::Event::Ok'); - push @out => $e->to_tap($idx, $delayed); - } - - for my $set (@out) { - $set->[1] =~ s/^/ /mg; - } - - return @out; -} - -sub extra_details { - my $self = shift; - - my @out = $self->SUPER::extra_details(); - my $plan = $self->[STATE]->[STATE_PLAN]; - my $exception = $self->exception; - - return ( - @out, - - events => $self->events || undef, - - exception => $exception || undef, - plan => $plan || undef, - - passing => $self->[STATE]->[STATE_PASSING], - count => $self->[STATE]->[STATE_COUNT], - failed => $self->[STATE]->[STATE_FAILED], - ); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Event::Subtest - Subtest event - -=head1 DESCRIPTION - -This event is used to encapsulate subtests. - -=head1 SYNOPSYS - -B. See the -C function from L instead. - -=head1 INHERITENCE - -the C class inherits from -L and shares all of its methods and fields. - -=head1 ACCESSORS - -=over 4 - -=item my $se = $e->events - -This returns an arrayref with all events generated during the subtest. - -=item my $x = $e->exception - -If the subtest was killed by a C or C the event will be -returned by this accessor. - -=back - -=head1 SUMMARY FIELDS - -C inherits all of the summary fields from -L. - -=over 4 - -=item events => \@subevents - -An arrayref containing all the events generated within the subtest, including -plans. - -=item exception => \$plan_or_bail - -If the subtest was aborted due to a bail-out or a skip_all, the event that -caused the abort will be here (in addition to the events arrayref. - -=item plan => \$plan - -The plan event for the subtest, this may be auto-generated. - -=item passing => $bool - -True if the subtest was passing, false otherwise. This should not be confused -with 'bool' inherited from L which takes TODO into -account. - -=item count => $num - -Number of tests run inside the subtest. - -=item failed => $num - -Number of tests that failed inside the subtest. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm b/cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm deleted file mode 100644 index 791ba14f6e..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm +++ /dev/null @@ -1,268 +0,0 @@ -package Test::Stream::ExitMagic; -use strict; -use warnings; - -require Test::Stream::ExitMagic::Context; - -use Test::Stream::ArrayBase( - accessors => [qw/pid done/], -); - -sub init { - $_[0]->[PID] = $$; - $_[0]->[DONE] = 0; -} - -sub do_magic { - my $self = shift; - my ($stream, $context) = @_; - return unless $stream; - return if $stream->no_ending && !$context; - - # Don't bother with an ending if this is a forked copy. Only the parent - # should do the ending. - return unless $self->[PID] == $$; - - # Only run once - return if $self->[DONE]++; - - my $real_exit_code = $?; - - $context ||= Test::Stream::ExitMagic::Context->new([caller()], $stream); - - if (!$stream->ended && $stream->follow_ups && @{$stream->follow_ups}) { - $context->set; - $_->($context) for @{$stream->follow_ups}; - $context->clear; - } - - my $plan = $stream->plan; - my $total = $stream->count; - my $fails = $stream->failed; - - $context->finish($total, $fails); - - # Ran tests but never declared a plan or hit done_testing - return $self->no_plan_magic($stream, $context, $total, $fails, $real_exit_code) - if $total && !$plan; - - # Exit if plan() was never called. This is so "require Test::Simple" - # doesn't puke. - return unless $plan; - - # Don't do an ending if we bailed out. - if( $stream->bailed_out ) { - $stream->is_passing(0); - return; - } - - # Figure out if we passed or failed and print helpful messages. - return $self->be_helpful_magic($stream, $context, $total, $fails, $plan, $real_exit_code) - if $total && $plan; - - if ($plan->directive && $plan->directive eq 'SKIP') { - $? = 0; - return; - } - - if($real_exit_code) { - $context->diag("Looks like your test exited with $real_exit_code before it could output anything.\n"); - $stream->is_passing(0); - $? = $real_exit_code; - return; - } - - unless ($total) { - $context->diag("No tests run!\n"); - $stream->is_passing(0); - $? = 255; - return; - } - - $stream->is_passing(0); - $? = 255; -} - -sub no_plan_magic { - my $self = shift; - my ($stream, $context, $total, $fails, $real_exit_code) = @_; - - $stream->is_passing(0); - $context->diag("Tests were run but no plan was declared and done_testing() was not seen."); - - if($real_exit_code) { - $context->diag("Looks like your test exited with $real_exit_code just after $total.\n"); - $? = $real_exit_code; - return; - } - - # But if the tests ran, handle exit code. - if ($total && $fails) { - my $exit_code = $fails <= 254 ? $fails : 254; - $? = $exit_code; - return; - } - - $? = 254; - return; -} - -sub be_helpful_magic { - my $self = shift; - my ($stream, $context, $total, $fails, $plan, $real_exit_code) = @_; - - my $planned = $plan->max; - my $num_extra = $plan->directive && $plan->directive eq 'NO PLAN' ? 0 : $total - $planned; - - if ($num_extra != 0) { - my $s = $planned == 1 ? '' : 's'; - $context->diag("Looks like you planned $planned test$s but ran $total.\n"); - $stream->is_passing(0); - } - - if($fails) { - my $s = $fails == 1 ? '' : 's'; - my $qualifier = $num_extra == 0 ? '' : ' run'; - $context->diag("Looks like you failed $fails test$s of ${total}${qualifier}.\n"); - $stream->is_passing(0); - } - - if($real_exit_code) { - $context->diag("Looks like your test exited with $real_exit_code just after $total.\n"); - $stream->is_passing(0); - $? = $real_exit_code; - return; - } - - my $exit_code; - if($fails) { - $exit_code = $fails <= 254 ? $fails : 254; - } - elsif($num_extra != 0) { - $exit_code = 255; - } - else { - $exit_code = 0; - } - - $? = $exit_code; - return; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::ExitMagic - Encapsulate the magic exit logic - -=head1 DESCRIPTION - -It's magic! well kinda.. - -=head1 SYNOPSYS - -Don't use this yourself, let L handle it. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm b/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm deleted file mode 100644 index 9832a68a2c..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm +++ /dev/null @@ -1,135 +0,0 @@ -package Test::Stream::ExitMagic::Context; -use strict; -use warnings; - -use Test::Stream::ArrayBase( - base => 'Test::Stream::Context', -); - -sub init { - $_[0]->[PID] = $$; - $_[0]->[ENCODING] = 'legacy'; -} - -sub snapshot { $_[0] } - -sub from_end_block { 1 }; - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::ExitMagic::Context - Special context for use in an END block. - -=head1 DESCRIPTION - -L needs to accomplish some magic in an END block. In an END block -it is not always possible to have a true/complete context object, so this -trivial one is used instead. - -B. If you find yourself thinking that you should use this then -B because you are very likely to be wrong. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Explanation.pod b/cpan/Test-Simple/lib/Test/Stream/Explanation.pod deleted file mode 100644 index 9314bb68b0..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Explanation.pod +++ /dev/null @@ -1,943 +0,0 @@ -package Test::Stream::Explanation; - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Explanation - Explanation of all things Test::Stream - -=head1 Summary of problems the new internals solve - -=over 4 - -=item Monolithic singleton - -=item Subtests are a horrible hack - -=item No event monitoring/munging - -=item Diags and Oks are not linked - -=item $Level is fragile, non-obvious, and actively harmful - -=item Depth ($Level) is a bad thing to test against - -=item There is no good way to validate testing tools, only mediocre ways - -=item Cannot reuse Test::More tools without generating TAP - -=item TAP is mandatory - -=item Setting the encoding requires major hackery - -=item No forking support - -=item Shared variable hackery in thread support - -=back - -=head1 Solutions - -=head2 Singleton - -The biggest problem with Test::Builder is that it does 2 things at once. The -first thing it does is synchronization, which is accomplished by making it a -singleton. The second thing it does is provide a collection of useful tools and -shortcuts for generating events. This is an issue because the tools are tied to -the singleton, Subclassing Test::Builder is not an option, and there are few -hooks. You essentially have to hack the Test::Builder object, and hope nobody -else does the same. - -Test::Stream now houses synchronization code, all events come to Test::Stream, -which makes sure the state is updated, and then forwards the events to where -they need to be, including producing the TAP output. This module synchronizes -state, threads, processes, and events. - -Unlike Test::Builder, Test::Stream is not a true singleton. Test::Stream has a -singleton stack, and code always uses the instance at the top of the stack. -This allows you to temporarily push an instance to the top in order to -intercept events. - -Anything not essential to synchronization is kept in other modules. This model -allows you to subclass tools as you see fit. You can create and destroy -instances as needed. You can create your own toolboxes without accounting for -the nature of a singleton. - -=head2 Subtests - -Do not read the subtest implementation in the legacy Test::Builder code, if -your eyes bleed that much you won't be able to finish reading this document. -They first copy the singleton, then reset the originals internals, do their -thing, then restore the original internals. This is not an attack against the -people that wrote it; they did the best that could be done with the singleton -they had to work with. The only way to write a better implementation is to move -away from the monolithic singleton model. - -Subtests are now integrated into the design of Test::Stream. Test::Stream -maintains a state stack. When a subtest starts it pushes a new state to the top -of the stack, when it is finished it pops the state. Designing the internals -with subtests in mind from the beginning significantly reduces the hackery -necessary to make them work. - -Note: There is still some other stuff that makes subtests non-trivial, such as -TODO inheritance. But most of the problems related to subtests are solved in -much saner ways now. - -=head2 Event Handling - -In Test::Builder, ok, diag, note, etc. were all simply methods. You call the -method you get some TAP. There was no easy way to hook into the system and -modify an event. There is also no easy way to listen for events, or maintain a -complete list, short of parsing TAP. - -All "events" are now proper objects. Tools generate events such as 'ok' and -'diag', then send them to the Test::Stream instance at the top of the stack. -Test::Stream provides hooks for you to modify events before the test state is -updated, as well as hooks for reading/displaying/storing events after the state -is updated. There is also a hook for the end of the test run (done_testing, or -test ended). - -This is what Test::Stream is named Test::Stream, all events stream from the -tools into the Test::Stream funnel, which then gets them where they need to go. -Previously these kinds of actions required monkeypatching. - -=head2 Linking ok and diag - -Tools would typically call C<< $TB->ok >>, then call C<< $TB->diag >>. Both -would produce output. There is no easy way to associate the diag and the ok. -Often the messages can appear out of order, or far apart. Usually a human can -figure out what goes where, but connecting them programmatically is very hard -to do after the fact. - -Diags and oks can still exist as independent events, but by default all Test::More -tools link the 'ok' and 'diag' events they produce. This allows code to process -the ok and attached diagnostics as one unit. This prevents guess work -previously required to accomplish this. Any downstream tool can also link 'ok' -and 'diag' objects, but they are not required to do so for compatibility -reasons. - -NOTE: Once the events are turned into TAP they still have the same issue as -before, TAP itself does not provide any way of linking the diag and the ok. - -=head2 $Level - -=head3 Whats the problem with $Level? - - local $Test::Builder::Level = $Test::Builder::Level + $x; - -At a glance the code above seems reasonable... But there are caveats: - -=over 4 - -=item What if you have multiple Test::Builder instances? - -Don't - -=item What about subtests? - -$Level is zeroed out and restored later. - -=item What if my unit tests validate the value of $Level, but Test::Builder adds another layer? - -Test::Builder can never break large subs into small ones for this reason. Or -better yet, don't use Test::Tester since you have to jump through hoops for it -to skip testing level. - -=item This is a non-obvious interface for new perl developers. - -This code requires you to know about local, package variables, and scope. In -some cases you also need to do math, something better left to the computer. - -=back - -=head3 How is it solved? - -L - -Instead of bumping $Level, you ask for a $context instance. You normally ask -for the $context at the shallowest level of your tools code. The context -figures out what file+line errors should be reported to, as well as recording -other critical per-test state such as TODO. - -Once you obtain a context, anything else that asks for the context will find -the one you already have. Once nothing is holding a reference to the context, a -new one can be generated. Essentially this lets the first tool in the stack -lock in a context, and all deeper tools find it. When your tool is finished the -Context is destroyed allowing the next tool to repeat the process. This lets -you stack tools arbitrarily without concerning yourself with depth value. - -Note: You can pass a level/depth value when obtaining a context if for some -reason you cannot obtain it at the shallowest level. - -Note: Context takes the value of $Level into account for compatibility reasons. -Backcompat like this adds an unfortunate level of complexity to Context. - -=head2 Validating test tools - -Test::Builder::Tester simply captures all output from Test::Builder. Your job -is to compare the strings it intercepts with the strings you expect. There are -a few helpers to reduce the tedious nature of these string compares, but -ultimately they are not very flexible. Changing the indentation of a comment -intended for human consumption can break any and all modules that use -Test::Builder::Tester. - -Test::Tester is a huge improvement, but lacks support for numerous features. -Test::Tester also works (worked) by replacing the singleton and monkeypatching -a lot of methods. Testing tools that also need to monkeypatch is not possible. -In addition it made too many assumptions about what you wanted to do with the -results it found. - -The solution here is Test::Stream::Tester. Test::Stream::Tester leverages the -stack nature of Test::Stream to intercept events generated over a specific -scope. These event objects can then be verified using well known tools from -Test::More, or the tools Test::Stream::Tester itself provides to make -validating events super easy. - -Another validation problem solved here is that you can filter, or be selective -about what events you care about. This allows you to test only the parts that -your module generates. This is helpful in ensuring changes upstream do not -break your tests unless they actually break your modules behavior. - -=head2 Resusable Test::More tools. - -Often people would write test subs that make use of tools such as C, -C, and others in a sequence to validate a single result. This -produces an 'ok' and/or diag for each tool used. In many cases people would -prefer to produce only a single final event, and a combined diagnostic message. -This is now possible. - -L and L solve this problem. Nearly -all the internals of Test::More have been moved into these 2 modules. The subs -in these modules return a boolean and diagnostics messages, but do not fire off -events. These are then wrapped in Test::More to actually produce the events. -Using these tools you can create composite tools that produce a single event. - -L is the base for is_deeply. This is useful because it -gives you a chance to create tools like is_deeply with similar diagnostics (for -better or worse). An example of this is L. - -=head2 Mandatory TAP. - -99% of the time you want TAP. With the old internals turning TAP off was hard, -and usually resulted in a useless Test::Builder. - -There is now a single switch you can use to turn TAP on and off. The listener -feature of Test::Stream gives you the ability to produce whatever output you -desire for any event that comes along. All the test state is still kept -properly. - -=head2 Setting the encoding - -Legacy Test::Builder would clone the standard filehandles, reset them, and -modify them in various ways as soon as it loaded. Changes made to STDERR and -STDOUT after this action would have no effect on Test::Builder. You could -modify/set/reset Test::Builders filehandles, but this was not obvious. Setting -the encoding of the handles in Test::Builder could also be dangerous as other -modules might have changes the handles. - -For compatibility reasons Test::Stream still has to do all the filehandle -manipulation Test::Builder did. However it encapsulates it better and makes it -significantly easier to modify. Every class that produces events gets a -meta-object. The meta-object has an option for encoding. You can ask for a -specific encoding when you load Test::More, or you can change it at any point -in the test. - -Encodings are managed by . Each Test::Stream instance has -an instance of L. The default encoding is called 'legacy' -and it does what Test::Builder has always done. You can ask for a specific -encoding, such as utf8, and IOSets will create a new clone of STDERR and STDOUT -and handle setting the encoding for you. IOSets can manage several encodings -all at once, so you can switch as necessary in your tests, or have multiple -tests under the same process that use different encodings. - -=head2 Threads and Forking - -Legacy Test::Builder does not support producing results from multiple threads -without serious hacking or questionable third party modules (Of which I own -one, and help maintain another). - -Legacy Test::Builder does support threading, but only if threads are loaded -first. It uses shared variables and locking to maintain the test state and -ensure test numbers are consistent. - -Test::Stream has forking support baked in (though you have to ask for it). -Thread support has been changed to use the same mechanism as forking support. -There are no shared variables. Test::Stream implements checks to ensure that -all events generated get funneled to the parent process/thread where they can -then be properly processed. - -=head1 Module justifications - -All code is a liability. Any module which is included in the dist requires -some justification. If there is no justification for including the module the -sensible thing to do would be to purge it. - -=head2 Test::Builder - -Required for legacy support and backwards compatibility. - -=head2 Test::Builder::Module - -Required for legacy support and backwards compatibility. In the past people -were urged to use this as a base class for all testing tools. To my knowledge -adoption was very low. - -=head2 Test::Builder::Tester - -Has been included for many years. Tightly coupled with the rest of the testing -tools. Wide adoption. - -=head3 Additional components - -=over 4 - -=item Test::Builder::Tester::Color - -=back - -=head2 Test::CanFork - -Encapsulation of some logic that used to be duplicated in several Test-Simple -tests. Now usable by anyone. - -This module lets you make a test conditional upon support for forking. - -=head2 Test::CanThread - -Encapsulation of some logic that used to be duplicated in several Test-Simple -tests. Now usable by anyone. - -This module lets you make a test conditional upon support for threads. - -=head2 Test::More - -This requires no justification. - -=head3 Additional components - -=over 4 - -=item Test::More::DeepCheck - -This is a base class for tools that resemble is_deeply. A lot of this is -valuable logic that is now reusable. - -=item Test::More::DeepCheck::Strict - -This is the subclass that implements is_Deeply itself. I will not that this was -a refactor, not a re-implementation, there should be zero net-change to how -is_deeply behaves. - -=item Test::More::Tools - -This is where the guts of Test::More tools live. This is here so that they can -be reused in composite tests without any hacking. This was a refactor, not -redesign from the ground up. - -=back - -=head2 Test::MostlyLike - -This implements a new tool similar to is_deeply called mostly_like. This is -included in the dist because I wrote it specifically to test the Test-Simple -internals. It is also useful enough to publish publicly. - -=head3 Additional components - -=over 4 - -=item Test::More::DeepCheck::Tolerant - -This is the subclass that implements mostly_like. - -=back - -=head2 Test::Simple - -This requires no justification. This is also the module the dist is named after. - -=head2 Test::Stream - -This is the new crux of Test-Simple. - -Test::Stream is the hub to which all events flow. It is also responsible for -ensuring all events get to the correct place. This is where all synchronization -happens. - -=head3 Additional components - -=over 4 - -=item Test::Stream::API - -This is sugar-coating. This is the go-to place when people wish to know the -easiest way to accomplish something fancy. - -=item Test::Stream::Meta - -Metadata assigned to test files/packages - -=item Test::Stream::PackageUtil - -Utilities for inspecting package internals - -=item Test::Stream::Subtest - -Encapsulation of subtest logic - -=item Test::Stream::Threads - -Encapsulation of threading tools - -=item Test::Stream::Util - -Misc Utilities used all over Test-Simple - -=back - -=head2 Test::Stream::ArrayBase - -All objects in Test::Stream use this to generate methods and constructors. This -is done here, and the way it is, for performance. Before implementing this ans -switching to it, performance was bad enough to keep the new internals out of -core. - -=head3 Additional components - -=over 4 - -=item Test::Stream::ArrayBase::Meta - -=back - -=head2 Test::Stream::Block - -Subtests are typically codeblocks. This is an object to represent them. There -is some development in this module that will provide profoundly useful -debugging for subtests, though it has not yet been enabled. This module is in -the dist mainly to give it a shakedown and prove it before turning on the extra -debugging. - -=head2 Test::Stream::Carp - -We cannot load Carp until we actually need it, if we do it can cause unexpected -test passes downstream. This is one of few core modules I am willing to do this -for, mainly because legacy had the same policy. - -This module provides the same tools as Carp, they simple load Carp and call the -correct sub from there. - -=head2 Test::Stream::Context - -This module is responsible for gathering details about events that are to be -generated. It is responsible for figuring out where errors should be reported, -if we are in a TODO, and various other meta-data. - -This module is an essential module. - -It also handles backwards compatibility with $Level, $TODO, and -C<< Test::Builder->todo_start >>. - -=head2 Test::Stream::Event - -All 'events' are now proper objects, this is the base class for all events. - -=head3 Additional components - -=over 4 - -=item Test::Stream::Event::Bail - -Event for bailing out. - -=item Test::Stream::Event::Diag - -Event for diagnostics - -=item Test::Stream::Event::Finish - -Event for the end of the test. - -=item Test::Stream::Event::Note - -Event for notes. - -=item Test::Stream::Event::Ok - -The 'ok' event is the most well known. This is an essential event. - -=item Test::Stream::Event::Plan - -This event is triggered whenever a plan is declared. - -=item Test::Stream::Event::Subtest - -Subtests are their own event, it is a subclass of the -L event. - -=back - -=head2 Test::Stream::ExitMagic - -This is where the magic that happens when a test process exists is -encapsulated. Some of this is pretty grody or questionable, nearly all of it is -here for legacy reasons. - -=head3 Additional components - -=over 4 - -=item Test::Stream::ExitMagic::Context - -Special Context object to use from ExitMagic. This is because a lot of Context -logic is a bad idea when run from an END block. - -=back - -=head2 Test::Stream::Exporter - -Test-Simple has to do a lot of exporting. Some of the exporting is not easy to -achieve using L. I can't use an export tool from cpan, so I had to -implement the bare minimum I needed here. - -=head3 Additional components - -=over 4 - -=item Test::Stream::Exporter::Meta - -=back - -=head2 Test::Stream::ForceExit - -This module is used to ensure that code exits by the end of a scope. This is -mainly for cases where you fork down stack from an eval and your code throws -and exception before it can exit. - -(A quick grep of the code tells me this is not in use anymore/yet. It can -probably be purged) - -=head2 Test::Stream::IOSets - -This is where filehandles and encodings are managed. This is here both to -implement legacy filehandle support, and to enable support for encodings. - -=head2 Test::Stream::Tester - -This module is intended to be the new and proper way to validate testing tools. -It supports all features of Test::Stream, and provides tools and helpers that -make the job easier. - -=head3 Additional components - -=over 4 - -=item Test::Stream::Tester::Checks - -=item Test::Stream::Tester::Checks::Event - -=item Test::Stream::Tester::Events - -=item Test::Stream::Tester::Events::Event - -=item Test::Stream::Tester::Grab - -=back - -=head2 Test::Stream::Toolset - -This module provides the minimum set of tools most test tools need to work. - -=head2 Test::Tester - -This is an important part of the ecosystem. It makes no sense to ship this -independently. Changes to Test-Simple can break this in any number of ways, -integration is the only sane option. - -=head3 Additional components - -Most of these remain for legacy support. - -=over 4 - -=item Test::Tester::Capture - -=item Test::Tester::CaptureRunner - -=item Test::Tester::Delegate - -=back - -=head2 Test::use::ok - -This module implements the sane companion to C which is C. -There has been a desire to combine this into Test-Simple for years, I finally -did it. - -=head3 Additional components - -=over 4 - -=item ok - -This is where the actual implementation lives. - -=back - -=head1 Compatability Shims - -Some modules need to jump through extra hoops in order to support legacy code. -This section describes these instances. - -=head2 Test::Builder - -Nearly everything in this module is here purely for legacy and compatibility. -But there are some extra-notable items: - -=over 4 - -=item $_ORIG_Test - -=item %ORIG - -=item %WARNED - -These 3 variables are used to track and warn about changes to the singleton or -method monkeypatching that could cause problems. - -=item ctx() - -A special context method that does extra C<$Level> accounting. - -=item %TB15_METHODS - -=item AUTOLOAD - -Used to warn people when they appear to be using Test::Builder 1.5 methods that -never actually made it into production anywhere. - -=item underscore methods - -There are several private methods (underscore prefix) that were never intended -for external use. Despite underscores, warnings, and other such things people -used them externally anyway. Most were purged, but these were left because an -unbelievable amount of downstream things appear to depend on them. - -=back - -=head2 Test::Stream - -The state array has an extra field identified by the constant C. -This is an array of all events of some types. Test::Builder used to maintain an -array of hashes representing events for inspection later. Code which relied on -this capability now depends on this and some translation logic in -Test::Builder. - -Unlike in old Test::Builder this feature can be turned off for performance and -memory improvement. - -=head2 Test::Stream::Util - -=over 4 - -=item is_dualvar - -Test::More has its own is_dualvar. This differs from Scalar::Utils dualvar -checker, enough to break cmp_ok. Because of the breakage I have not switched. - -=item is_regex - -Test::More tools check if things are regexes in many places. The way it does -this, and the things it considers to be regexes are suprising. Much of this is -due to VERY old code that might predate quick regexes. Switching away from this -would break a lot of things. - -=item unoverload - -Test::More has its own ideas of unoverloading things and when it is necessary. -Not safe to migrate away from this. - -=back - -=head2 Test::Stream::Context - -=over 4 - -=item TODO - -Has to look for todo in 4 places. $TODO in the test package, $TODO in -Test::More, the todo value of the Test::Builder singleton, and the todo in test -package meta-data. The main issue here is no good TODO system has ever been -found, so we use and support 4 mediocre or even bad ones. - -=item $Level - -Test::Builder has historically been very forgiving and clever when it comes to -$Level. Context takes $Level into account when finding the proper file + line -number for reporting errors. If $Level is wrong it attempts to be as forgiving -as Test::Builder was. Requiring $Level to be correct breaks an unfortunate -number of downstream tools, so we have to stay forgiving for now. - -=item Test::Builder monkeypatching - -When Test::Builder gets monkeypatched, we need to detect it here and try to -incorporate the monkeypatching. This is a horrible hack that works surprisingly -well. - -=item hide_todo + restore_todo - -Subtests need to hide the TODO state, they have always done this historically. -These methods accomplish this... for all 4 ways you can set TODO. - -=back - -=head2 Test::Stream::ExitMagic - -Test::Builder does a lot of stuff at exit. I would argue that a lot of this -should be harness logic. However compatibility and people relying on it means -we cannot just remove it all at once. - -This magic is called though either an END block, or done_testing. Sometimes -both. - -=head2 Test::Stream::IOSets - -Test::Builder clones STDERR and STDOUT and resets them to what it thinks they -should be. This encapsulates that logic and calls it 'legacy'. It then provides -mechanisms for actually supporting custom filehandles and encodings. - -=head2 Test::Tester - -This makes use of the STATE_LEGACY key mentioned in the Test::Stream section. -This also needs to do some gymnastics and monkeypatching for $Level support. - -=head1 Design Decisions - -=head2 Test::Builder - -Decided to turn this into a legacy wrapper. It is no longer essential for -anything new. - -=head2 Test::More - -Decided to refactor the logic out into reusable parts. No net change except for -some bug fixes. - -At one point some redesign was started, but it was abandoned, this mainly had -to do with use_ok and require_ok, which are horrible. - -=head3 Additional components - -Most logic was moved into these 3 modules - -=over 4 - -=item Test::More::DeepCheck - -is_deeply stack and diagnostics - -=item Test::More::DeepCheck::Strict - -is_deeply inner check functions - -=item Test::More::Tools - -Everything else. - -=back - -=head2 Test::Stream - -=over 4 - -=item Instead of a singleton, we have a stack of singletons - -We can't avoid using a singleton-like pattern when we are dealing with a shared -state. However there are times where we need to work around the singleton -model. The main example is writing tests for testing tools. The singleton stack -allows us to put new instances in place that will steal focus. - -Anything that produces events should send them to the topmost instance of -Test::Stream. Using tools like Test::Stream::Context and Test::Builder handle -this for you. - -In the old system you were expected to cache a copy of the Test::Builder -singleton, this caused problems when code needed to replace the singleton. -Subtests had to implement and ugly hack around this problem. In the new system -test state is also a stack, subtests work by pushing a new state, they do not -need to replace the entire singleton. - -=item Only state and synchronization is handled here - -Since this module is somewhat singleton in nature, we keep it as small as -possible. Anything that is put into a singleton-like object is hard to expand. -If it is not related to synchronization or common state, I tried to put it -somewhere else. - -=item Events are proper objects - -In the old design events were just methods that produced TAP. Now they are -proper objects that can be constructed, altered, passed around, etc. - -=item This module is a hub through which events stream - -Events are built by testing tools, once ready the events are given to -Test::Stream to ensure they get to the right place. - -=back - -=head2 Test::Stream::Meta - -Attaching meta-data to tests was a design decision adopted for settings that -people want, but might be different from test file to test file. Being able to -use different settings in different files is necessary for advanced testing -tools that might load multiple files at a time. Examples include Fennec, -Test::Class, etc. - -Currently TODO and tap_encoding are the only significant settings here. - -=head2 Test::Stream::ArrayBase - -This is the OO implementation used all over Test::Stream. The initial upgrade -to OO from a single object where hash elements were directly accessed resulted -in a significant slowdown. - -To avoid the slowdown a couple design decision were made: - -=over 4 - -=item Objects would be array based - -=item Constants would be used to access elements - -=item Single inheritance only for simplicity - -=item Seperate reader+writer methods - -=item generate methods for each attribute that use $_[xxx] and constants - -=back - -Together these designs resulted in huge performance gains. - -=head2 Test::Stream::Context - -The context object is created when a testing tool is called. Any testing tools -called within will find the existing context. This context stores important -things like test file, line number, etc. - -This is implemented as a weak singleton. When a tool gets a context is is -crated. When a tool returns the context is garbage collected and destroyed. -This allows the next tool to obtain a new context. - -=head2 Test::Stream::Event::Subtest - -The subtest event is a subclass of the ok event. This is done because a subtest -ultimately boils down to an 'ok'. - -=head2 Test::Stream::Exporter - -Test::Stream has to do some fancy exporting, specially due to -Test::Stream::ArrayBase and the attribute constants. This exporter is a very -light implementation modeled on Exporter::Declare. It uses a meta-object to -track exports. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Exporter.pm b/cpan/Test-Simple/lib/Test/Stream/Exporter.pm deleted file mode 100644 index 237560a330..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Exporter.pm +++ /dev/null @@ -1,328 +0,0 @@ -package Test::Stream::Exporter; -use strict; -use warnings; - -use Test::Stream::PackageUtil; -use Test::Stream::Exporter::Meta; - -sub export; -sub exports; -sub default_export; -sub default_exports; - -# Test::Stream::Carp uses this module. -sub croak { require Carp; goto &Carp::croak } -sub confess { require Carp; goto &Carp::confess } - -BEGIN { Test::Stream::Exporter::Meta->new(__PACKAGE__) }; - -sub import { - my $class = shift; - my $caller = caller; - - Test::Stream::Exporter::Meta->new($caller); - - export_to($class, $caller, @_); -} - -default_exports qw/export exports default_export default_exports/; -exports qw/export_to export_meta export_to_level/; - -default_export import => sub { - my $class = shift; - my $caller = caller; - my @args = @_; - - my $stash = $class->before_import($caller, \@args) if $class->can('before_import'); - export_to($class, $caller, @args); - $class->after_import($caller, $stash, @args) if $class->can('after_import'); -}; - -sub export_meta { - my $pkg = shift || caller; - return Test::Stream::Exporter::Meta->get($pkg); -} - -sub export_to { - my $class = shift; - my ($dest, @imports) = @_; - - my $meta = Test::Stream::Exporter::Meta->new($class); - - my (@include, %exclude); - for my $import (@imports) { - if (substr($import, 0, 1) eq '!') { - $import =~ s/^!//g; - $exclude{$import}++; - } - else { - push @include => $import; - } - } - - @include = $meta->default unless @include; - - my $exports = $meta->exports; - for my $name (@include) { - next if $exclude{$name}; - - my $ref = $exports->{$name} - || croak qq{"$name" is not exported by the $class module}; - - no strict 'refs'; - $name =~ s/^[\$\@\%\&]//; - *{"$dest\::$name"} = $ref; - } -} - -sub export_to_level { - my $class = shift; - my ($level, undef, @want) = @_; - - my $dest = caller($level); - my $export_to = $class->can('export_to') || \&export_to; - - $class->$export_to($dest, @want); -} - -sub cleanup { - my $pkg = caller; - package_purge_sym($pkg, map {(CODE => $_)} qw/export exports default_export default_exports/); -} - -sub export { - my ($name, $ref) = @_; - my $caller = caller; - - my $meta = export_meta($caller) || - confess "$caller is not an exporter!?"; - - $meta->add($name, $ref); -} - -sub exports { - my $caller = caller; - - my $meta = export_meta($caller) || - confess "$caller is not an exporter!?"; - - $meta->add_bulk(@_); -} - -sub default_export { - my ($name, $ref) = @_; - my $caller = caller; - - my $meta = export_meta($caller) || - confess "$caller is not an exporter!?"; - - $meta->add_default($name, $ref); -} - -sub default_exports { - my $caller = caller; - - my $meta = export_meta($caller) || - confess "$caller is not an exporter!?"; - - $meta->add_default_bulk(@_); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Exporter - Declarative exporter for Test::Stream and friends. - -=head1 DESCRIPTION - -Test::Stream::Exporter is an internal implementation of some key features from -L. This is a much more powerful exporting tool than -L. This package is used to easily manage complicated EXPORT logic -across L and friends. - -=head1 SYNOPSYS - - use Test::Stream::Exporter; - - # Export some named subs from the package - default_exports qw/foo bar baz/; - exports qw/fluxx buxx suxx/; - - # Export some anonymous subs under specific names. - export some_tool => sub { ... }; - default_export another_tool => sub { ... }; - - # Call this when you are done providing exports in order to cleanup your - # namespace. - Test::Stream::Exporter->cleanup; - - # Hooks for import() - - # Called before importing symbols listed in $args_ref. This gives you a - # chance to munge the arguments. - sub before_import { - my $class = shift; - my ($caller, $args_ref) = @_; - ... - - return $stash; # For use in after_import, can be anything - } - - # Chance to do something after import() is done - sub after_import { - my $class = shift; - my ($caller, $stash, @args) = @_; - ... - } - -=head1 EXPORTS - -=head2 DEFAULT - -=over 4 - -=item import - -Your class needs this to function as an exporter. - -=item export NAME => sub { ... } - -=item default_export NAME => sub { ... } - -These are used to define exports that may not actually be subs in the current -package. - -=item exports qw/foo bar baz/ - -=item default_exports qw/foo bar baz/ - -These let you export package subs en mass. - -=back - -=head2 AVAILABLE - -=over 4 - -=item export_to($from, $dest, @symbols) - -=item $from->export_to($dest, @symbols) - -Export from the C<$from> package into the C<$dest> package. The class-method -form only works if the method has been imported into the C<$from> package. - -=item $meta = export_meta($package) - -=item $meta = $package->export_meta() - -Get the export meta object from the package. The class method form only works -if the package has imported it. - -=back - -=head1 HOOKS - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm b/cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm deleted file mode 100644 index 0bdf93533a..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm +++ /dev/null @@ -1,237 +0,0 @@ -package Test::Stream::Exporter::Meta; -use strict; -use warnings; - -use Test::Stream::PackageUtil; - -# Test::Stream::Carp uses this module. -sub croak { require Carp; goto &Carp::croak } -sub confess { require Carp; goto &Carp::confess } - -sub exports { $_[0]->{exports} } -sub default { @{$_[0]->{pdlist}} } -sub all { @{$_[0]->{polist}} } - -sub add { - my $self = shift; - my ($name, $ref) = @_; - - confess "Name is mandatory" unless $name; - - confess "$name is already exported" - if $self->exports->{$name}; - - $ref ||= package_sym($self->{package}, $name); - - confess "No reference or package sub found for '$name' in '$self->{package}'" - unless $ref && ref $ref; - - $self->exports->{$name} = $ref; - push @{$self->{polist}} => $name; -} - -sub add_default { - my $self = shift; - my ($name, $ref) = @_; - - $self->add($name, $ref); - push @{$self->{pdlist}} => $name; - - $self->{default}->{$name} = 1; -} - -sub add_bulk { - my $self = shift; - for my $name (@_) { - confess "$name is already exported" - if $self->exports->{$name}; - - my $ref = package_sym($self->{package}, $name) - || confess "No reference or package sub found for '$name' in '$self->{package}'"; - - $self->{exports}->{$name} = $ref; - } - - push @{$self->{polist}} => @_; -} - -sub add_default_bulk { - my $self = shift; - - for my $name (@_) { - confess "$name is already exported by $self->{package}" - if $self->exports->{$name}; - - my $ref = package_sym($self->{package}, $name) - || confess "No reference or package sub found for '$name' in '$self->{package}'"; - - $self->{exports}->{$name} = $ref; - $self->{default}->{$name} = 1; - } - - push @{$self->{polist}} => @_; - push @{$self->{pdlist}} => @_; -} - -my %EXPORT_META; - -sub new { - my $class = shift; - my ($pkg) = @_; - - confess "Package is required!" - unless $pkg; - - unless($EXPORT_META{$pkg}) { - # Grab anything set in @EXPORT or @EXPORT_OK - my (@pdlist, @polist); - { - no strict 'refs'; - @pdlist = @{"$pkg\::EXPORT"}; - @polist = @{"$pkg\::EXPORT_OK"}; - - @{"$pkg\::EXPORT"} = (); - @{"$pkg\::EXPORT_OK"} = (); - } - - my $meta = bless({ - exports => {}, - default => {}, - pdlist => do { no strict 'refs'; no warnings 'once'; \@{"$pkg\::EXPORT"} }, - polist => do { no strict 'refs'; no warnings 'once'; \@{"$pkg\::EXPORT_OK"} }, - package => $pkg, - }, $class); - - $meta->add_default_bulk(@pdlist); - my %seen = map {$_ => 1} @pdlist; - $meta->add_bulk(grep {!$seen{$_}++} @polist); - - $EXPORT_META{$pkg} = $meta; - } - - return $EXPORT_META{$pkg}; -} - -sub get { - my $class = shift; - my ($pkg) = @_; - - confess "Package is required!" - unless $pkg; - - return $EXPORT_META{$pkg}; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Exporter::Meta - Meta object for exporters. - -=head1 DESCRIPTION - -L uses this package to manage exports. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/ForceExit.pm b/cpan/Test-Simple/lib/Test/Stream/ForceExit.pm deleted file mode 100644 index 32efb58170..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/ForceExit.pm +++ /dev/null @@ -1,97 +0,0 @@ -package Test::Stream::ForceExit; -use strict; -use warnings; - -sub new { - my $class = shift; - - my $done = 0; - my $self = \$done; - - return bless $self, $class; -} - -sub done { - my $self = shift; - ($$self) = @_ if @_; - return $$self; -} - -sub DESTROY { - my $self = shift; - return if $self->done; - - warn "Something prevented child process $$ from exiting when it should have, Forcing exit now!\n"; - $self->done(1); # Prevent duplicate message during global destruction - exit 255; -} - -1; - -__END__ - -=head1 NAME - -Test::ForceExit - Ensure C is called by the end of a scope, force the issue. - -=head1 DESCRIPTION - -Sometimes you need to fork. Sometimes the forked process can throw an exception -to exit. If you forked below an eval the exception will be cought and you -suddenly have an unexpected process running amok. This module can be used to -protect you from such issues. - -=head1 SYNOPSYS - - eval { - ... - - my $pid = fork; - - unless($pid) { - require Test::Stream::ForceExit; - my $force_exit = Test::Stream::ForceExit->new; - - thing_that_can_die(); - - # We did not die, turn off the forced exit. - $force_exit->done(1); - - # Do the exit we intend. - exit 0; - } - - ... - } - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/cpan/Test-Simple/lib/Test/Stream/IOSets.pm b/cpan/Test-Simple/lib/Test/Stream/IOSets.pm deleted file mode 100644 index c76b6755c7..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/IOSets.pm +++ /dev/null @@ -1,245 +0,0 @@ -package Test::Stream::IOSets; -use strict; -use warnings; - -use Test::Stream::Util qw/protect/; - -init_legacy(); - -sub new { - my $class = shift; - my $self = bless {}, $class; - - $self->reset_legacy; - - return $self; -} - -sub init_encoding { - my $self = shift; - my ($name, @handles) = @_; - - unless($self->{$name}) { - my ($out, $fail, $todo); - - if (@handles) { - ($out, $fail, $todo) = @handles; - } - else { - ($out, $fail) = $self->open_handles(); - } - - binmode($out, ":encoding($name)"); - binmode($fail, ":encoding($name)"); - - $self->{$name} = [$out, $fail, $todo || $out]; - } - - return $self->{$name}; -} - -my $LEGACY; -sub hard_reset { $LEGACY = undef } -sub init_legacy { - return if $LEGACY; - - my ($out, $err) = open_handles(); - - _copy_io_layers(\*STDOUT, $out); - _copy_io_layers(\*STDERR, $err); - - _autoflush($out); - _autoflush($err); - - # LEGACY, BAH! - # This is necessary to avoid out of sequence writes to the handles - _autoflush(\*STDOUT); - _autoflush(\*STDERR); - - $LEGACY = [$out, $err, $out]; -} - -sub reset_legacy { - my $self = shift; - init_legacy() unless $LEGACY; - my ($out, $fail, $todo) = @$LEGACY; - $self->{legacy} = [$out, $fail, $todo]; -} - -sub _copy_io_layers { - my($src, $dst) = @_; - - protect { - require PerlIO; - my @src_layers = PerlIO::get_layers($src); - _apply_layers($dst, @src_layers) if @src_layers; - }; - - return; -} - -sub _autoflush { - my($fh) = pop; - my $old_fh = select $fh; - $| = 1; - select $old_fh; - - return; -} - -sub open_handles { - open( my $out, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; - open( my $err, ">&STDERR" ) or die "Can't dup STDERR: $!"; - - _autoflush($out); - _autoflush($err); - - return ($out, $err); -} - -sub _apply_layers { - my ($fh, @layers) = @_; - my %seen; - my @unique = grep { $_ !~ /^(unix|perlio)$/ && !$seen{$_}++ } @layers; - binmode($fh, join(":", "", "raw", @unique)); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::IOSets - Manage sets of IO Handles in specific encodings. - -=head1 DESCRIPTION - -The module does 2 things, first it emulates the old behavior of -L which clones and modifies the STDOUT and STDERR handles. This -legacy behavior can be referenced as C<'legacy'> in place of an encoding. It -also manages multiple clones of the standard file handles which are set to -specific encodings. - -=head1 METHODS - -In general you should not use this module yourself. If you must use it directly -then there is really only 1 method you should use: - -=over 4 - -=item $ar = $ioset->init_encoding($ENCODING) - -=item $ar = $ioset->init_encoding('legacy') - -=item $ar = $ioset->init_encoding($NAME, $STDOUT, $STDERR) - -C will return an arrayref of 3 filehandles, STDOUT, STDERR, -and TODO. TODO is typically just STDOUT again. If the encoding specified has -not yet been initialized it will initialize it. If you provide filehandles they -will be used, but only during initializatin. Typically a filehandle set is -created by cloning STDER and STDOUT and modifying them to use the correct -encoding. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Meta.pm b/cpan/Test-Simple/lib/Test/Stream/Meta.pm deleted file mode 100644 index 68e6641deb..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Meta.pm +++ /dev/null @@ -1,204 +0,0 @@ -package Test::Stream::Meta; -use strict; -use warnings; - -use Scalar::Util(); -use Test::Stream::Util qw/protect/; - -use Test::Stream::ArrayBase( - accessors => [qw/package encoding modern todo stream/], -); - -use Test::Stream::PackageUtil; - -use Test::Stream::Exporter qw/import export_to default_exports/; -default_exports qw{ is_tester init_tester }; -Test::Stream::Exporter->cleanup(); - -my %META; - -sub snapshot { - my $self = shift; - my $class = Scalar::Util::blessed($self); - return bless [@$self], $class; -} - -sub is_tester { - my $pkg = shift; - return $META{$pkg}; -} - -sub init_tester { - my $pkg = shift; - $META{$pkg} ||= bless [$pkg, 'legacy', 0, undef], __PACKAGE__; - return $META{$pkg}; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Meta - Meta object for unit test packages. - -=head1 DESCRIPTION - -This object is used to track metadata for unit tests packages. - -=head1 SYNOPSYS - - use Test::Stream::Meta qw/init_tester is_tester/; - - sub import { - my $class = shift; - my $caller = caller; - - my $meta = init_tester($caller); - } - - sub check_stuff { - my $caller = caller; - my $meta = is_tester($caller) || return; - - ... - } - -=head1 EXPORTS - -=over 4 - -=item $meta = is_tester($package) - -Get the meta object for a specific package, if it has one. - -=item $meta = init_tester($package) - -Get the meta object for a specific package, or create one. - -=back - -=head1 METHODS - -=over 4 - -=item $meta_copy = $meta->snapshot - -Get a snapshot copy of the metadata. This snapshot will not change when the -original does. - -=item $val = $meta->package - -=item $val = $meta->encoding - -=item $val = $meta->modern - -=item $val = $meta->todo - -=item $val = $meta->stream - -These are various attributes stored on the meta object. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm b/cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm deleted file mode 100644 index 03a82487f2..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm +++ /dev/null @@ -1,210 +0,0 @@ -package Test::Stream::PackageUtil; -use strict; -use warnings; - -sub confess { require Carp; goto &Carp::confess } - -my @SLOTS = qw/HASH SCALAR ARRAY IO FORMAT CODE/; -my %SLOTS = map {($_ => 1)} @SLOTS; - -my %SIGMAP = ( - '&' => 'CODE', - '%' => 'HASH', - '$' => 'SCALAR', - '*' => 'IO', -); - -sub import { - my $caller = caller; - no strict 'refs'; - *{"$caller\::package_sym"} = \&package_sym; - *{"$caller\::package_purge_sym"} = \&package_purge_sym; - 1; -} - -sub package_sym { - my ($pkg, @parts) = @_; - confess "you must specify a package" unless $pkg; - - my ($slot, $name); - - if (@parts > 1) { - ($slot, $name) = @parts; - } - elsif (@parts) { - my $sig; - ($sig, $name) = $parts[0] =~ m/^(\W)?(\w+)$/; - $slot = $SIGMAP{$sig || '&'}; - } - - confess "you must specify a symbol type" unless $slot; - confess "you must specify a symbol name" unless $name; - - confess "'$slot' is not a valid symbol type! Valid: " . join(", ", @SLOTS) - unless $SLOTS{$slot}; - - no warnings 'once'; - no strict 'refs'; - return *{"$pkg\::$name"}{$slot}; -} - -sub package_purge_sym { - my ($pkg, @pairs) = @_; - - for(my $i = 0; $i < @pairs; $i += 2) { - my $purge = $pairs[$i]; - my $name = $pairs[$i + 1]; - - confess "'$purge' is not a valid symbol type! Valid: " . join(", ", @SLOTS) - unless $SLOTS{$purge}; - - no strict 'refs'; - local *GLOBCLONE = *{"$pkg\::$name"}; - my $stash = \%{"${pkg}\::"}; - delete $stash->{$name}; - for my $slot (@SLOTS) { - next if $slot eq $purge; - *{"$pkg\::$name"} = *GLOBCLONE{$slot} if defined *GLOBCLONE{$slot}; - } - } -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::PackageUtil - Utils for manipulating package symbol tables. - -=head1 DESCRIPTION - -Collection of utilities L and friends use to manipulate package -symbol tables. This is primarily useful when trackign things like C<$TODO> -vars. It is also used for exporting and meta-construction of object methods. - -=head1 EXPORTS - -Both exports are exported by default, you cannot pick and choose. These work -equally well as functions and class-methods. These will not work as object -methods. - -=over 4 - -=item $ref = package_sym($PACKAGE, $SLOT => $NAME) - -Get the reference to a symbol in the package. C<$PACKAGE> should be the package -name. C<$SLOT> should be a valid typeglob slot (Supported slots: HASH SCALAR ARRAY -IO FORMAT CODE). C<$NAME> should be the name of the symbol. - -=item package_purge_sym($PACKAGE, $SLOT => $NAME, $SLOT2 => $NAME2, ...) - -This is used to remove symbols from a package. The first argument, C<$PACKAGE>, -should be the name of the package. The remaining arguments should be key/value -pairs. The key in each pair should be the typeglob slot to clear (Supported -slots: HASH SCALAR ARRAY IO FORMAT CODE). The value in the pair should be the -name of the symbol to remove. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Subtest.pm b/cpan/Test-Simple/lib/Test/Stream/Subtest.pm deleted file mode 100644 index 97e274eaeb..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Subtest.pm +++ /dev/null @@ -1,218 +0,0 @@ -package Test::Stream::Subtest; -use strict; -use warnings; - -use Test::Stream::Exporter; -default_exports qw/subtest/; -Test::Stream::Exporter->cleanup; - -use Test::Stream::Context qw/context/; -use Scalar::Util qw/reftype blessed/; -use Test::Stream::Util qw/try/; -use Test::Stream::Carp qw/confess/; - -use Test::Stream::Block; - -sub subtest { - my ($name, $code, @args) = @_; - - my $ctx = context(); - - $ctx->throw("subtest()'s second argument must be a code ref") - unless $code && 'CODE' eq reftype($code); - - my $block = Test::Stream::Block->new( - $name, $code, undef, [caller(0)], - ); - - $ctx->note("Subtest: $name") - if $ctx->stream->subtest_tap_instant; - - my $st = $ctx->subtest_start($name); - - my $pid = $$; - my ($succ, $err) = try { - TEST_STREAM_SUBTEST: { - no warnings 'once'; - local $Test::Builder::Level = 1; - $block->run(@args); - } - - return if $st->{early_return}; - - $ctx->set; - my $stream = $ctx->stream; - $ctx->done_testing unless $stream->plan || $stream->ended; - - require Test::Stream::ExitMagic; - { - local $? = 0; - Test::Stream::ExitMagic->new->do_magic($stream, $ctx->snapshot); - } - }; - - my $er = $st->{early_return}; - if (!$succ) { - # Early return is not a *real* exception. - if ($er && $er == $err) { - $succ = 1; - $err = undef; - } - else { - $st->{exception} = $err; - } - } - - if ($$ != $pid) { - warn <<" EOT" unless $ctx->stream->_use_fork; -Subtest finished with a new PID ($$ vs $pid) while forking support was turned off! -This is almost certainly not what you wanted. Did you fork and forget to exit? - EOT - - # Did the forked process try to exit via die? - # If a subtest forked, then threw an exception, we need to propogate that right away. - die $err unless $succ; - } - - my $st_check = $ctx->subtest_stop($name); - confess "Subtest mismatch!" unless $st == $st_check; - - $ctx->bail($st->{early_return}->reason) if $er && $er->isa('Test::Stream::Event::Bail'); - - my $e = $ctx->subtest( - # Stuff from ok (most of this gets initialized inside) - undef, # real_bool, gets set properly by initializer - $st->{name}, # name - undef, # diag - undef, # bool - undef, # level - - # Subtest specific stuff - $st->{state}, - $st->{events}, - $st->{exception}, - $st->{early_return}, - $st->{delayed}, - $st->{instant}, - ); - - die $err unless $succ; - - return $e->bool; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 Name - -Test::Stream::Subtest - Encapsulate subtest start, run, and finish. - -=head1 Synopsys - - use Test::Stream::Subtest; - - subtest $name => sub { ... }; - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester.pm b/cpan/Test-Simple/lib/Test/Stream/Tester.pm deleted file mode 100644 index 111dc73f55..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Tester.pm +++ /dev/null @@ -1,727 +0,0 @@ -package Test::Stream::Tester; -use strict; -use warnings; - -use Test::Builder 1.301001; -use Test::Stream; -use Test::Stream::Util qw/try/; - -use B; - -use Scalar::Util qw/blessed reftype/; -use Test::Stream::Carp qw/croak carp/; - -use Test::Stream::Tester::Checks; -use Test::Stream::Tester::Checks::Event; -use Test::Stream::Tester::Events; -use Test::Stream::Tester::Events::Event; - -use Test::Stream::Toolset; -use Test::Stream::Exporter; -default_exports qw{ - intercept grab - - events_are - check event directive -}; - -default_export dir => \&directive; -Test::Stream::Exporter->cleanup; - -sub grab { - require Test::Stream::Tester::Grab; - return Test::Stream::Tester::Grab->new; -} - -our $EVENTS; -sub check(&) { - my ($code) = @_; - - my $o = B::svref_2object($code); - my $st = $o->START; - my $file = $st->file; - my $line = $st->line; - - local $EVENTS = Test::Stream::Tester::Checks->new($file, $line); - - my @out = $code->($EVENTS); - - if (@out) { - if ($EVENTS->populated) { - carp "sub used in check(&) returned values, did you forget to prefix an event with 'event'?" - } - else { - croak "No events were produced by sub in check(&), but the sub returned some values, did you forget to prefix an event with 'event'?"; - } - } - - return $EVENTS; -} - -sub event($$) { - my ($type, $data) = @_; - - croak "event() cannot be used outside of a check { ... } block" - unless $EVENTS; - - my $etypes = Test::Stream::Context->events; - croak "'$type' is not a valid event type!" - unless $etypes->{$type}; - - my $props; - - croak "event() takes a type, followed by a hashref" - unless ref $data && reftype $data eq 'HASH'; - - # Make a copy - $props = { %{$data} }; - - my @call = caller(0); - $props->{debug_package} = $call[0]; - $props->{debug_file} = $call[1]; - $props->{debug_line} = $call[2]; - - $EVENTS->add_event($type, $props); - return (); -} - -sub directive($;$) { - my ($directive, @args) = @_; - - croak "directive() cannot be used outside of a check { ... } block" - unless $EVENTS; - - croak "No directive specified" - unless $directive; - - if (!ref $directive) { - croak "Directive '$directive' requires exactly 1 argument" - unless (@args && @args == 1) || $directive eq 'end'; - } - else { - croak "directives must be a predefined name, or a sub ref" - unless reftype($directive) eq 'CODE'; - } - - $EVENTS->add_directive(@_); - return (); -} - -sub intercept(&) { - my ($code) = @_; - - my @events; - - my ($ok, $error) = try { - Test::Stream->intercept( - sub { - my $stream = shift; - $stream->listen( - sub { - shift; # Stream - push @events => @_; - } - ); - $code->(); - } - ); - }; - - die $error unless $ok || (blessed($error) && $error->isa('Test::Stream::Event')); - - return \@events; -} - -sub events_are { - my ($events, $checks, $name) = @_; - - croak "Did not get any events" - unless $events; - - croak "Did not get any checks" - unless $checks; - - croak "checks must be an instance of Test::Stream::Tester::Checks" - unless blessed($checks) - && $checks->isa('Test::Stream::Tester::Checks'); - - my $ctx = context(); - - # use $_[0] directly so that the variable used in the method call can be undef'd - $events = $_[0]->finish - if blessed($events) - && $events->isa('Test::Stream::Tester::Grab'); - - $events = Test::Stream::Tester::Events->new(@$events) - if ref($events) - && reftype($events) eq 'ARRAY'; - - croak "'$events' is not a valid set of events." - unless $events - && blessed($events) - && $events->isa('Test::Stream::Tester::Events'); - - my ($ok, @diag) = $checks->run($events); - - $ctx->ok($ok, $name, \@diag); - return $ok; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Tester - Tools for validating the events produced by your testing -tools. - -=head1 DESCRIPTION - -There are tools to validate your code. This library provides tools to validate -your tools! - -=head1 SYNOPSIS - - use Test::More; - use Test::Stream::Tester; - - events_are( - # Capture all the events within the block - intercept { - ok(1, "pass"); - ok(0, "fail"); - diag("xxx"); - }, - - # Describe what we expect to see - check { - event ok => {bool => 1, name => 'pass'}; - event ok => { - bool => 0, - name => 'fail', - - # Ignores any fields in the result we don't list - # real_bool, line, file, tool_package, tool_name, etc... - - # Diagnostics generated by a test are typically linked to those - # results (new and updated tools only) They can be validated. - diag => qr/^Failed test /, - }; - event diag => {message => 'xxx'}; - directive 'end'; # enforce that there are no more results - }, - - "This is the name of our test" - ); - - done_testing; - -=head2 GRAB WITH NO ADDED STACK - - use Test::More; - use Test::Stream::Tester; - - # Start capturing events. We use grab() instead of intercept {} to avoid - # adding stack frames. - my $grab = grab(); - - # Generate some events. - ok(1, "pass"); - ok(0, "fail"); - diag("xxx"); - - # Stop capturing events, and validate the ones recieved. - events_are( - $grab, - check { - event ok => { bool => 1, name => 'pass' }; - event ok => { bool => 0, name => 'fail' }; - event diag => { message => 'xxx' }; - directive 'end'; - }, - 'Validate our Grab results'; - ); - - # $grab is now undef, it no longer exists. - is($grab, undef, '$grab was destroyed for us.'); - - ok(!$success, "Eval did not succeed, BAIL_OUT killed the test"); - - # Make sure we got the event as an exception - isa_ok($error, 'Test::Stream::Event::Bail'); - - done_testing - -=head1 EXPORTS - -=over 4 - -=item $events = intercept { ... } - -=item $events = intercept(sub { ... }) - -Capture the L objects generated by tests inside the block. - -=item events_are(\@events, $check) - -=item events_are(\@events, $check, $name) - -=item events_are($events, $check) - -=item events_are($events, $check, $name) - -=item events_are($grab, $check) - -=item events_are($grab, $check, $name) - -The first argument may be either an arrayref of L objects, -an L object, or an L -object. C can be used to capture events within a block of -code, including plans such as C, and things that normally kill the -test like C. - -The second argument must be an L object. -Typically these are generated using C. - -The third argument is the name of the test, it is optional, but highly -recommended. - -=item $checks = check { ... }; - -Produce an array of expected events for use in events_are. - - my $check = check { - event ok => { ... }; - event diag => { ... }; - directive 'end'; - }; - -If the block passed to check returns anything at all it will warn you as this -usually means you forgot to use the C and/or C functions. If it -returns something AND has no events it will be fatal. - -C and C both return nothing, this means that if you use -them alone your codeblock will return nothing. - -=item event TYPE => { ... }; - -Define an event and push it onto the list that will be returned by the -enclosing C block. Will fail if run outside a check block. This -will fail if you give it an invalid event type. - -If you wish to acknowledge the event, but not check anything you may simply -give it an empty hashref. - -The line number where the event was generated is recorded for helpful debugging -in event of a failure. - -B The line number is inexact because of the way perl records it. The -line number is taken from C. - -=item dir 'DIRECTIVE'; - -=item dir DIRECTIVE => 'ARG'; - -=item dir sub { ... }; - -=item dir sub { ... }, $arg; - -=item directive 'DIRECTIVE'; - -=item directive DIRECTIVE => 'ARG'; - -=item directive sub { ... }; - -=item directive sub { ... }, $arg; - -Define a directive and push it onto the list that will be returned by the -enclosing C block. This will fail if run outside of a check -block. - -The first argument must be either a codeblock, or one of the name of a -predefined directive I. - -Coderefs will be given 3 arguments: - - sub { - my ($checks, $events, $arg) = @_; - ... - } - -C<$checks> is the L object. C<$events> is the -L object. C<$arg> is whatever argument you passed -via the C call. - -Most directives will act on the C<$events> object to remove or alter events. - -=back - -=head1 INTERCEPTING EVENTS - - my $events = intercept { - ok(1, "pass"); - ok(0, "fail"); - diag("xxx"); - }; - -Any events generated within the block will be intercepted and placed inside -the C<$events> array reference. - -=head2 EVENT TYPES - -All events will be subclasses of L - -=over 4 - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=back - -=head1 VALIDATING EVENTS - -You can validate events by hand using traditional test tools such as -C against the $events array returned from C. However -it is easier to use C paried with C objects build using -C. - - events_are( - intercept { - ok(1, "pass"); - ok(0, "fail"); - diag("xxx"); - }, - - check { - event ok => { bool => 1, name => 'pass' }; - event ok => { bool => 0, name => 'fail' }; - event diag => {message => 'xxx'}; - directive 'end'; - }, - - "This is the name of our test" - ); - -=head2 WHAT DOES THIS BUY ME? - -C, C, and C, work together to produce a -nested set of objects to represent what you want to see. This was chosen over a -hash/list system for 2 reasons: - -=over 4 - -=item Better Diagnostics - -Whenever you use C, C, and C it records -the filename and line number where they are called. When a test fails the -diagnostics will include this information so that you know where the error -occured. In a hash/list based system this information is not available. - -A hash based system is not practical as you may generate several events of the -same type, and in a hash duplicated keys are squashed (last one wins). - -A list based system works, but then a failure reports the index of the failure, -this requires you to manually count events to find the correct one. Originally -I tried letting you specify an ID for the events, but this proved annoying. - -Ultimately I am very happy with the diagnostics this allows. It is very nice to -see what is essentially a simple trace showing where the event and check were -generated. It also shows you the items leading to the failure in the event of -nested checks. - -=item Loops and other constructs - -In a list based system you are limited in what you can produce. You can -generate the list in advance, then pass it in, but this is hard to debug. -Alternatively you can use C to produce repeated events, but this is -equally hard to debug. - -This system lets you call C and C in loops directly. It -also lets you write functions that produce them based on input for reusable -test code. - -=back - -=head2 VALIDATING FIELDS - -The hashref against which events are checked is composed of keys, and values. -The values may be regular values, which are checked for equality with the -corresponding property of the event object. Alternatively you can provide a -regex to match against, or an arrayref of regexes (each one must match). - -=over 4 - -=item field => 'exact_value', - -The specified field must exactly match the given value, be it number or string. - -=item field => qr/.../, - -The specified field must match the regular expression. - -=item field => [qr/.../, qr/.../, ...], - -The value of the field must match ALL the regexes. - -=item field => sub { ... } - -Specify a sub that will validate the value of the field. - - foo => sub { - my ($key, $val) = @_; - - ... - - # Return true (valid) or false, and any desired diagnostics messages. - return($bool, @diag); - }, - -=back - -=head2 WHAT FIELDS ARE AVAILABLE? - -This is specific to the event type. All events inherit from -L which provides a C method. The C -method returns a list of key/value pairs I<(not a reference!)> with all fields -that are for public consumption. - -For each of the following modules see the B section for a list -of fields made available. These fields are inherited when events are -subclassed, and all events have the summary fields present in -L. - -=over 4 - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=back - -=head2 DIRECTIVES - -Directives give you a chance to alter the list of events part-way through the -check, or to make the check skip/ignore events based on conditions. - -=head3 skip - -Skip will skip a specific number of events at that point in the check. - -=over 4 - -=item directive skip => $num; - - my $events = intercept { - ok(1, "foo"); - diag("XXX"); - - ok(1, "bar"); - diag("YYY"); - - ok(1, "baz"); - diag("ZZZ"); - }; - - events_are( - $events, - ok => { name => "foo" }, - - skip => 1, # Skips the diag 'XXX' - - ok => { name => "bar" }, - - skip => 2, # Skips the diag 'YYY' and the ok 'baz' - - diag => { message => 'ZZZ' }, - ); - -=back - -=head3 seek - -When turned on (true), any unexpected events will be skipped. You can turn -this on and off any time by using it again with a false argument. - -=over 4 - -=item directive seek => $BOOL; - - my $events = intercept { - ok(1, "foo"); - - diag("XXX"); - diag("YYY"); - - ok(1, "bar"); - diag("ZZZ"); - - ok(1, "baz"); - }; - - events_are( - $events, - - seek => 1, - ok => { name => "foo" }, - # The diags are ignored, it will seek to the next 'ok' - ok => { name => "bar" }, - - seek => 0, - - # This will fail because the diag is not ignored anymore. - ok => { name => "baz" }, - ); - -=back - -=head3 end - -Used to say that there should not be any more events. Without this any events -after your last check are simply ignored. This will generate a failure if any -unchecked events remain. - -=over 4 - -=item directive 'end'; - -=back - -=head1 SEE ALSO - -=over 4 - -=item L *Deprecated* - -A nice, but very limited tool for testing 'ok' results. - -=item L *Deprecated* - -The original test tester, checks TAP output as giant strings. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm deleted file mode 100644 index d032807c13..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm +++ /dev/null @@ -1,403 +0,0 @@ -package Test::Stream::Tester::Checks; -use strict; -use warnings; - -use Test::Stream::Carp qw/croak confess/; -use Test::Stream::Util qw/is_regex/; - -use Scalar::Util qw/blessed reftype/; - -my %DIRECTIVES = ( - map { $_ => __PACKAGE__->can($_) } - qw(filter_providers filter_types skip seek end) -); - -sub new { - my $class = shift; - my ($file, $line) = @_; - my $self = bless { - seek => 0, - items => [], - file => $file, - line => $line, - }, $class; - return $self; -} - -sub debug { - my $self = shift; - return "Checks from $self->{file} around line $self->{line}."; -} - -sub populated { scalar @{shift->{items}} } - -sub add_directive { - my $self = shift; - my ($dir, @args) = @_; - - confess "No directive provided!" - unless $dir; - - if (ref($dir)) { - confess "add_directive takes a coderef, or name, and optional args. (got $dir)" - unless reftype($dir) eq 'CODE'; - } - else { - confess "$dir is not a valid directive." - unless $DIRECTIVES{$dir}; - $dir = $DIRECTIVES{$dir}; - } - - push @{$self->{items}} => [$dir, @args]; -} - -sub add_event { - my $self = shift; - my ($type, $spec) = @_; - - confess "add_event takes a type name and a hashref" - unless $type && $spec && ref $spec && reftype($spec) eq 'HASH'; - - my $e = Test::Stream::Tester::Checks::Event->new(%$spec, type => $type); - push @{$self->{items}} => $e; -} - -sub include { - my $self = shift; - my ($other) = @_; - - confess "Invalid argument to include()" - unless $other && blessed($other) && $other->isa(__PACKAGE__); - - push @{$self->{items}} => @{$other->{items}}; -} - -sub run { - my $self = shift; - my ($events) = @_; - $events = $events->clone; - - for (my $i = 0; $i < @{$self->{items}}; $i++) { - my $item = $self->{items}->[$i]; - - # Directive - if (reftype $item eq 'ARRAY') { - my ($code, @args) = @$item; - my @out = $self->$code($events, @args); - next unless @out; - return @out; - } - - # Event! - my $meth = $self->{seek} ? 'seek' : 'next'; - my $event = $events->$meth($item->get('type')); - - my ($ret, @debug) = $self->check_event($item, $event); - return ($ret, @debug) unless $ret; - } - - return (1); -} - -sub vtype { - my ($v) = @_; - - if (blessed($v)) { - return 'checks' if $v->isa('Test::Stream::Tester::Checks'); - return 'events' if $v->isa('Test::Stream::Tester::Events'); - return 'check' if $v->isa('Test::Stream::Tester::Checks::Event'); - return 'event' if $v->isa('Test::Stream::Tester::Events::Event'); - } - - return 'regexp' if defined is_regex($v); - return 'noref' unless ref $v; - return 'array' if reftype($v) eq 'ARRAY'; - return 'code' if reftype($v) eq 'CODE'; - - confess "Invalid field check: '$v'"; -} - -sub check_event { - my $self = shift; - my ($want, $got) = @_; - - my @debug = (" Check: " . $want->debug); - my $wtype = $want->get('type'); - - return (0, @debug, " Expected event of type '$wtype', but did not find one.") - unless defined($got); - - unshift @debug => " Event: " . $got->debug; - my $gtype = $got->get('type'); - - return (0, @debug, " Expected event of type '$wtype', but got '$gtype'.") - unless $wtype eq $gtype; - - for my $key ($want->keys) { - my $wval = $want->get($key); - my $gval = $got->get($key); - - my ($ret, @err) = $self->check_key($key, $wval, $gval); - return ($ret, @debug, @err) unless $ret; - } - - return (1); -} - -sub check_key { - my $self = shift; - my ($key, $wval, $gval) = @_; - - if ((defined $wval) xor(defined $gval)) { - $wval = defined $wval ? "'$wval'" : 'undef'; - $gval = defined $gval ? "'$gval'" : 'undef'; - return (0, " \$got->{$key} = $gval", " \$exp->{$key} = $wval",); - } - - my $wtype = vtype($wval); - - my $meth = "_check_field_$wtype"; - return $self->$meth($key, $wval, $gval); -} - -sub _check_field_checks { - my $self = shift; - my ($key, $wval, $gval) = @_; - - my $debug = $wval->debug; - - return (0, " \$got->{$key} = '$gval'", " \$exp->{$key} = <$debug>") - unless vtype($gval) eq 'events'; - - my ($ret, @diag) = $wval->run($gval); - return $ret if $ret; - return ($ret, map { s/^/ /mg; $_ } @diag); -} - -sub _check_field_check { - my $self = shift; - my ($key, $wval, $gval) = @_; - - my $debug = $wval->debug; - - return (0, "Event: INVALID EVENT ($gval)", " Check: $debug") - unless vtype($gval) eq 'event'; - - my ($ret, @diag) = check_event($wval, $gval); - return $ret if $ret; - - return ($ret, map { s/^/ /mg; $_ } @diag); -} - -sub _check_field_noref { - my $self = shift; - my ($key, $wval, $gval) = @_; - - return (1) if !defined($wval) && !defined($gval); - return (1) if defined($wval) && defined($gval) && "$wval" eq "$gval"; - $wval = "'$wval'" if defined $wval; - $wval ||= 'undef'; - $gval = "'$gval'" if defined $gval; - $gval ||= 'undef'; - return (0, " \$got->{$key} = $gval", " \$exp->{$key} = $wval"); -} - -sub _check_field_regexp { - my $self = shift; - my ($key, $wval, $gval) = @_; - - return (1) if $gval =~ /$wval/; - return (0, " \$got->{$key} = '$gval'", " Does not match $wval"); -} - -sub _check_field_array { - my $self = shift; - my ($key, $wval, $gval) = @_; - for my $p (@$wval) { - my ($ret, @diag) = $self->_check_field_regexp($key, $p, $gval); - return ($ret, @diag) unless $ret; - } - - return (1); -} - -sub _check_field_code { - my $self = shift; - my ($key, $wval, $gval) = @_; - $wval->($key, $gval); -} - -sub seek { - my $self = shift; - my ($events, $flag) = @_; - - $self->{seek} = $flag ? 1 : 0; - - return (); # Cannot fail -} - -sub skip { - my $self = shift; - my ($events, $num) = @_; - $events->next while $num--; - return (); -} - -sub end { - my $self = shift; - my ($events) = @_; - my $event = $events->next; - return () unless $event; - return (0, " Expected end of events, got " . $event->debug); -} - -sub filter_providers { - my $self = shift; - my ($events, $arg) = @_; - - my ($neg, $val) = $arg =~ m/^(!?)(.*)$/; - if ($neg) { - @$events = grep { $_->get('tool_package') ne $val } @$events; - } - else { - @$events = grep { $_->get('tool_package') eq $val } @$events; - } - - return (); -} - -sub filter_types { - my $self = shift; - my ($events, $arg) = @_; - - my ($neg, $val) = $arg =~ m/^(!?)(.*)$/; - if ($neg) { - @$events = grep { $_->get('type') ne $val } @$events; - } - else { - @$events = grep { $_->get('type') eq $val } @$events; - } - - return (); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Tester::Checks - Representation of a L -event check. - -=head1 DESCRIPTION - -L produces this object whenever you use C. -In general you will not interact with this object directly beyond pasing it -into C. - -B The API for this object is not published and is subject to change. No backwords -compatability can be guarenteed if you use this object directly. Please only -use this object in the published way specified in L. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm deleted file mode 100644 index 649b3e75e2..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm +++ /dev/null @@ -1,197 +0,0 @@ -package Test::Stream::Tester::Checks::Event; -use strict; -use warnings; - -use Test::Stream::Util qw/is_regex/; -use Test::Stream::Carp qw/confess croak/; - -use Scalar::Util qw/blessed reftype/; - -sub new { - my $class = shift; - my $fields = {@_}; - my $self = bless {fields => $fields}, $class; - - $self->{$_} = delete $fields->{$_} - for qw/debug_line debug_file debug_package/; - - map { $self->validate_check($_) } values %$fields; - - my $type = $self->get('type') || confess "No type specified!"; - - my $etypes = Test::Stream::Context->events; - confess "'$type' is not a valid event type" - unless $etypes->{$type}; - - return $self; -} - -sub debug_line { shift->{debug_line} } -sub debug_file { shift->{debug_file} } -sub debug_package { shift->{debug_package} } - -sub debug { - my $self = shift; - - my $type = $self->get('type'); - my $file = $self->debug_file; - my $line = $self->debug_line; - - return "'$type' from $file line $line."; -} - -sub keys { sort keys %{shift->{fields}} } - -sub exists { - my $self = shift; - my ($field) = @_; - return exists $self->{fields}->{$field}; -} - -sub get { - my $self = shift; - my ($field) = @_; - return $self->{fields}->{$field}; -} - -sub validate_check { - my $self = shift; - my ($val) = @_; - - return unless defined $val; - return unless ref $val; - return if defined is_regex($val); - - if (blessed($val)) { - return if $val->isa('Test::Stream::Tester::Checks'); - return if $val->isa('Test::Stream::Tester::Events'); - return if $val->isa('Test::Stream::Tester::Checks::Event'); - return if $val->isa('Test::Stream::Tester::Events::Event'); - } - - my $type = reftype($val); - return if $type eq 'CODE'; - - croak "'$val' is not a valid field check" - unless reftype($val) eq 'ARRAY'; - - croak "Arrayrefs given as field checks may only contain regexes" - if grep { ! defined is_regex($_) } @$val; - - return; -} - -1; -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Tester::Checks::Event - Representation of an event validation -specification. - -=head1 DESCRIPTION - -Used internally by L. Please do not use directly. No -backwords compatability will be provided if the API for this module changes. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm deleted file mode 100644 index 529fdee408..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm +++ /dev/null @@ -1,169 +0,0 @@ -package Test::Stream::Tester::Events; -use strict; -use warnings; - -use Scalar::Util qw/blessed/; - -use Test::Stream::Tester::Events::Event; - -sub new { - my $class = shift; - my $self = bless [map { Test::Stream::Tester::Events::Event->new($_->summary) } @_], $class; - return $self; -} - -sub next { shift @{$_[0]} }; - -sub seek { - my $self = shift; - my ($type) = @_; - - while (my $e = shift @$self) { - return $e if $e->{type} eq $type; - } - - return undef; -} - -sub clone { - my $self = shift; - my $class = blessed($self); - return bless [@$self], $class; -} - -1; -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Tester::Events - Event list used by L. - -=head1 DESCRIPTION - -L converts lists of events into instances of this object -for use in various tools. You will probably never need to directly use this -class. - -=head1 METHODS - -=over 4 - -=item $events = $class->new(@EVENTS); - -Create a new instance from a list of events. - -=item $event = $events->next - -Get the next event. - -=item $event = $events->seek($type) - -Get the next event of the specific type (not a package name). - -=item $copy = $events->clone() - -Clone the events list object in its current state. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm deleted file mode 100644 index 0c3e2063f8..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm +++ /dev/null @@ -1,202 +0,0 @@ -package Test::Stream::Tester::Events::Event; -use strict; -use warnings; - -use Test::Stream::Carp qw/confess/; -use Scalar::Util qw/reftype blessed/; - -sub new { - my $class = shift; - my $self = bless {}, $class; - - my @orig = @_; - - while (@_) { - my $field = shift; - my $val = shift; - - if (exists $self->{$field}) { - use Data::Dumper; - print Dumper(@orig); - confess "'$field' specified more than once!"; - } - - if (my $type = reftype $val) { - if ($type eq 'ARRAY') { - $val = Test::Stream::Tester::Events->new(@$val) - unless grep { !blessed($_) || !$_->isa('Test::Stream::Event') } @$val; - } - elsif (blessed($val) && $val->isa('Test::Stream::Event')) { - $val = $class->new($val->summary); - } - } - - $self->{$field} = $val; - } - - return $self; -} - -sub get { - my $self = shift; - my ($field) = @_; - return $self->{$field}; -} - -sub debug { - my $self = shift; - - my $type = $self->get('type'); - my $file = $self->get('file'); - my $line = $self->get('line'); - - return "'$type' from $file line $line."; -} - -1; -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Tester::Events::Event - L representation of -an event. - -=head1 DESCRIPTION - -L often uses this clas to represent events in a way that -is easier to validate. - -=head1 SYNOPSYS - - use Test::Stream::Tester::Events::Event; - - my $event = Test::Stream::Tester::Events::Event->new($e->summary); - - # Print the file and line number where the event was generated - print "Debug: " . $event->debug . "\n"; - - # Get an event field value - my $val = $event->get($field); - -=head1 METHODS - -=over 4 - -=item $event->get($field) - -Get the value of a specific event field. Fields are specific to event types. -The fields are usually the result of calling C<< $e->summary >> on the original -event. - -=item $event->debug - -Returns a string like this: - - 'ok' from my_test.t line 42. - -Which lists the type of event, the file that generated, and the line number on -which it was generated. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm b/cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm deleted file mode 100644 index 8022011024..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm +++ /dev/null @@ -1,215 +0,0 @@ -package Test::Stream::Tester::Grab; -use strict; -use warnings; - -sub new { - my $class = shift; - - my $self = bless { - events => [], - streams => [ Test::Stream->intercept_start ], - }, $class; - - $self->{streams}->[0]->listen( - sub { - shift; # Stream - push @{$self->{events}} => @_; - } - ); - - return $self; -} - -sub flush { - my $self = shift; - my $out = delete $self->{events}; - $self->{events} = []; - return $out; -} - -sub events { - my $self = shift; - # Copy - return [@{$self->{events}}]; -} - -sub finish { - my ($self) = @_; # Do not shift; - $_[0] = undef; - - $self->{finished} = 1; - my ($remove) = $self->{streams}->[0]; - Test::Stream->intercept_stop($remove); - - return $self->flush; -} - -sub DESTROY { - my $self = shift; - return if $self->{finished}; - my ($remove) = $self->{streams}->[0]; - Test::Stream->intercept_stop($remove); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Tester::Grab - Object used to temporarily steal all events. - -=head1 DESCRIPTION - -Once created this object will intercept and stash all events sent to the shared -L object. Once the object is destroyed events will once again be -sent to the shared stream. - -=head1 SYNOPSYS - - use Test::More; - use Test::Stream::Tester::Grab; - - my $grab = Test::Stream::Tester::Grab->new(); - - # Generate some events, they are intercepted. - ok(1, "pass"); - ok(0, "fail"); - - my $events_a = $grab->flush; - - # Generate some more events, they are intercepted. - ok(1, "pass"); - ok(0, "fail"); - - # Same as flush, except it destroys the grab object. - my $events_b = $grab->finish; - -After calling C the grab object is destroyed and C<$grab> is set to -undef. C<$events_a> is an arrayref with the first 2 events. C<$events_b> is an -arrayref with the second 2 events. - -=head1 METHODS - -=over 4 - -=item $grab = $class->new() - -Create a new grab object, immediately starts intercepting events. - -=item $ar = $grab->flush() - -Get an arrayref of all the events so far, clearing the grab objects internal -list. - -=item $ar = $grab->events() - -Get an arrayref of all events so far, does not clear the internal list. - -=item $ar = $grab->finish() - -Get an arrayref of all the events, then destroy the grab object. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Threads.pm b/cpan/Test-Simple/lib/Test/Stream/Threads.pm deleted file mode 100644 index 2a90c6b119..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Threads.pm +++ /dev/null @@ -1,165 +0,0 @@ -package Test::Stream::Threads; -use strict; -use warnings; - -BEGIN { - use Config; - if( $Config{useithreads} && $INC{'threads.pm'} ) { - eval q| - sub get_tid { threads->tid() } - sub USE_THREADS() { 1 } - 1; - | || die $@; - } - else { - eval q| - sub get_tid() { 0 } - sub USE_THREADS() { 0 } - 1; - | || die $@; - } -} - -use Test::Stream::Exporter; -default_exports qw/get_tid USE_THREADS/; -Test::Stream::Exporter->cleanup; - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Threads - Tools for using threads with Test::Stream. - -=head1 DESCRIPTION - -This module provides some helpers for Test::Stream and Toolsets to use to -determine if threading is in place. In most cases you will not need to use this -module yourself. - -=head1 SYNOPSYS - - use threads; - use Test::Stream::Threads; - - if (USE_THREADS) { - my $tid = get_tid(); - } - -=head1 EXPORTS - -=over 4 - -=item USE_THREADS - -This is a constant, it is set to true when Test::Stream is aware of, and using, threads. - -=item get_tid - -This will return the id of the current thread when threads are enabled, -otherwise it returns 0. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Toolset.pm b/cpan/Test-Simple/lib/Test/Stream/Toolset.pm deleted file mode 100644 index c13086a090..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Toolset.pm +++ /dev/null @@ -1,419 +0,0 @@ -package Test::Stream::Toolset; -use strict; -use warnings; - -use Test::Stream::Context qw/context/; -use Test::Stream::Meta qw/is_tester init_tester/; -use Test::Stream::Carp qw/carp/; - -# Preload these so the autoload is not necessary -use Test::Stream::Event::Bail; -use Test::Stream::Event::Diag; -use Test::Stream::Event::Finish; -use Test::Stream::Event::Note; -use Test::Stream::Event::Ok; -use Test::Stream::Event::Plan; -use Test::Stream::Event::Subtest; - -use Test::Stream::Exporter qw/import export_to default_exports export/; -default_exports qw/is_tester init_tester context/; - -export before_import => sub { - my $class = shift; - my ($importer, $list) = @_; - - my $meta = init_tester($importer); - - my $context = context(1); - my $other = []; - my $idx = 0; - - while ($idx <= $#{$list}) { - my $item = $list->[$idx++]; - next unless $item; - - if (defined $item and $item eq 'no_diag') { - Test::Stream->shared->set_no_diag(1); - } - elsif ($item eq 'tests') { - $context->plan($list->[$idx++]); - } - elsif ($item eq 'skip_all') { - $context->plan(0, 'SKIP', $list->[$idx++]); - } - elsif ($item eq 'no_plan') { - $context->plan(0, 'NO PLAN'); - } - elsif ($item eq 'import') { - push @$other => @{$list->[$idx++]}; - } - else { - carp("Unknown option: $item"); - } - } - - @$list = @$other; - - return; -}; - -Test::Stream::Exporter->cleanup(); - - -1; -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Toolset - Helper for writing testing tools - -=head1 DESCRIPTION - -This package provides you with tools to write testing tools. It makes your job -of integrating with L and other testing tools much easier. - -=head1 SYNOPSYS - - package My::Tester; - use strict; - use warnings; - use Test::Stream::Toolset; - - # Optional, you can just use Exporter if you would like - use Test::Stream::Exporter; - - # These can come from Test::More, so do not export them by default - # exports is the Test::Stream::Exporter equivilent to @EXPORT_OK - exports qw/context done_testing/; - - # These are the API we want to provide, export them by default - # default_exports is the Test::Stream::Exporter equivilent to @EXPORT - default_exports qw/my_ok my_note/; - - sub my_ok { - my ($test, $name) = @_; - my $ctx = context(); - - my @diag; - push @diag => "'$test' is not true!" unless $test; - - $ctx->ok($test, $name, \@diag); - - return $test ? 1 : 0; # Reduce to a boolean - } - - sub my_note { - my ($msg) = @_; - my $ctx = context(); - - $ctx->note($msg); - - return $msg; - } - - sub done_testing { - my ($expected) = @_; - my $ctx = context(); - $ctx->done_testing($expected); - } - - 1; - -=head2 TEST-MORE STYLE IMPORT - -If you want to be able to pass Test-More arguments such as 'tests', 'skip_all', -and 'no_plan', then use the following: - - package My::Tester; - use Test::Stream::Exporter; # Gives us 'import()' - use Test::Stream::Toolset; # default exports - use Test::Stream::Toolset 'before_import' # Test-More style argument support - -2 'use' statements were used above for clarity, you can get all the desired -imports at once: - - use Test::Stream::Toolset qw/context init_tester is_tester before_import/; - -Then in the test: - - use My::Tester tests => 5; - -=head1 EXPORTS - -=over 4 - -=item $ctx = context() - -The context() method is used to get the current context, generating one if -necessary. The context object is an instance of L, and -is used to generate events suck as C and C. The context also knows -what file+line errors should be reported at. - -B Do not directly store the context in anything other than a lexical -variable scoped to your function! As long as there are references to a context -object, C will return that object. You want the object to be -destroyed at the end of the current scope so that the next function you call -can create a new one. If you need a copy of the context use -C<< $ctx = $ctx->snapshot >>. - -=item $meta = init_tester($CLASS) - -This method can be used to initialize a class as a test class. In most cases -you do not actually need to use this. If the class is already a tester this -will return the existing meta object. - -=item $meta = is_tester($CLASS) - -This method can be used to check if an object is a tester. If the object is a -tester it will return the meta object for the tester. - -=item before_import - -This method is used by C to parse Test-More style import arguments. -You should never need to run this yourself, it works just by being imported. - -B This will only work if you use Test::Stream::Exporter for your -'import' method. - -=back - -=head1 GENERATING EVENTS - -Events are always generated via a context object. Whenever you load an -L class it will add a method to L -which can be used to fire off that type of event. - -The following event types are all loaded automatically by -L - -=over 4 - -=item L - - $ctx->ok($bool, $name, \@diag) - -Ok events are your actual assertions. You assert that a condition is what you -expect. It is recommended that you name your assertions. You can include an -array of diag objects and/or diagniostics strings that will be printed to -STDERR as comments in the event of a failure. - -=item L - - $ctx->diag($MESSAGE) - -Produce an independant diagnostics message. - -=item L - - $ctx->note($MESSAGE) - -Produce a note, that is a message that is printed to STDOUT as a comment. - -=item L - - $ctx->plan($MAX, $DIRECTIVE, $REASON) - -This will set the plan. C<$MAX> should be the number of tests you expect to -run. You may set this to 0 for some plan directives. Examples of directives are -C<'skip_all'> and C<'no_plan'>. Some directives have an additional argument -called C<$REASON> which is aptly named as the reason for the directive. - -=item L - - $ctx->bail($MESSAGE) - -In the event of a catostrophic failure that should terminate the test file, use -this event to stop everything and print the reason. - -=item L - -=item L - -These are not intended for public use, but are documented for completeness. - -=back - -=head1 MODIFYING EVENTS - -If you want to make changes to event objects before they are processed, you can -add a munger. The return from a munger is ignored, you must make your changes -directly to the event object. - - Test::Stream->shared->munge(sub { - my ($stream, $event) = @_; - ... - }); - -B every munger is called for every event of every type. There is also no -way to remove a munger. For performance reasons it is best to only ever add one -munger per toolset which dispatches according to events and state. - -=head1 LISTENING FOR EVENTS - -If you wish to know when an event has occured so that you can do something -after it has been processed, you can add a listener. Your listener will be -called for every single event that occurs, after it has been processed. The -return from a listener is ignored. - - Test::Stream->shared->listen(sub { - my ($stream, $event) = @_; - ... - }); - -B every listener is called for every event of every type. There is also no -way to remove a listener. For performance reasons it is best to only ever add one -listener per toolset which dispatches according to events and state. - -=head1 I WANT TO EMBED FUNCTIONALITY FROM TEST::MORE - -Take a look at L which provides an interfaces to the code in -Test::More. You can use that library to produce booleans and diagnostics -without actually triggering events, giving you the opportunity to generate your -own. - -=head1 FROM TEST::BUILDER TO TEST::STREAM - -This is a list of things people used to override in Test::Builder, and the new -API that should be used instead of overrides. - -=over 4 - -=item ok - -=item note - -=item diag - -=item plan - -In the past people would override these methods on L. -L now provides a proper API for handling all event types. - -Anything that used to be done via overrides can now be done using -cshared->listen(sub { ... })> and -Cshared->munge(sub { ... })>, which are documented above. - -=item done_testing - -In the past people have overriden C to insert some code between -the last test and the final plan. The proper way to do this now is with a -follow_up hook. - - Test::Stream->shared->follow_up(sub { - my ($context) = @_; - ... - }); - -There are multiple ways that follow_ups will be triggered, but they are -guarenteed to only be called once, at the end of testing. This will either be -the start of C, or an END block called after your tests are -complete. - -=back - -=head1 HOW DO I TEST MY TEST TOOLS? - -See L. This library gives you all the tools you need to -test your testing tools. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Util.pm b/cpan/Test-Simple/lib/Test/Stream/Util.pm deleted file mode 100644 index 79b8087f6a..0000000000 --- a/cpan/Test-Simple/lib/Test/Stream/Util.pm +++ /dev/null @@ -1,380 +0,0 @@ -package Test::Stream::Util; -use strict; -use warnings; - -use Scalar::Util qw/reftype blessed/; -use Test::Stream::Exporter qw/import export_to exports/; -use Test::Stream::Carp qw/croak/; - -exports qw{ - try protect spoof is_regex is_dualvar - unoverload unoverload_str unoverload_num - translate_filename -}; - -Test::Stream::Exporter->cleanup(); - -sub _manual_protect(&) { - my $code = shift; - - my ($ok, $error); - { - my ($msg, $no) = ($@, $!); - $ok = eval { $code->(); 1 } || 0; - $error = $@ || "Error was squashed!\n"; - ($@, $!) = ($msg, $no); - } - die $error unless $ok; - return $ok; -} - -sub _local_protect(&) { - my $code = shift; - - my ($ok, $error); - { - local ($@, $!); - $ok = eval { $code->(); 1 } || 0; - $error = $@ || "Error was squashed!\n"; - } - die $error unless $ok; - return $ok; -} - -sub _manual_try(&) { - my $code = shift; - my $error; - my $ok; - - { - my ($msg, $no) = ($@, $!); - my $die = delete $SIG{__DIE__}; - - $ok = eval { $code->(); 1 } || 0; - unless($ok) { - $error = $@ || "Error was squashed!\n"; - } - - ($@, $!) = ($msg, $no); - $SIG{__DIE__} = $die; - } - - return wantarray ? ($ok, $error) : $ok; -} - -sub _local_try(&) { - my $code = shift; - my $error; - my $ok; - - { - local ($@, $!, $SIG{__DIE__}); - $ok = eval { $code->(); 1 } || 0; - unless($ok) { - $error = $@ || "Error was squashed!\n"; - } - } - - return wantarray ? ($ok, $error) : $ok; -} - -BEGIN { - if ($^O eq 'MSWin32' && $] < 5.020002) { - *protect = \&_manual_protect; - *try = \&_manual_try; - } - else { - *protect = \&_local_protect; - *try = \&_local_try; - } -} - - -sub spoof { - my ($call, $code, @args) = @_; - - croak "The first argument to spoof must be an arrayref with package, filename, and line." - unless $call && @$call == 3; - - croak "The second argument must be a string to run." - if ref $code; - - my $error; - my $ok; - - protect { - $ok = eval <<" EOT" || 0; -package $call->[0]; -#line $call->[2] "$call->[1]" -$code; -1; - EOT - unless($ok) { - $error = $@ || "Error was squashed!\n"; - } - }; - - return wantarray ? ($ok, $error) : $ok; -} - -sub is_regex { - my ($pattern) = @_; - - return undef unless defined $pattern; - - return $pattern if defined &re::is_regexp - && re::is_regexp($pattern); - - my $type = reftype($pattern) || ''; - - return $pattern if $type =~ m/^regexp?$/i; - return $pattern if $type eq 'SCALAR' && $pattern =~ m/^\(\?.+:.*\)$/s; - return $pattern if !$type && $pattern =~ m/^\(\?.+:.*\)$/s; - - my ($re, $opts); - - if ($pattern =~ m{^ /(.*)/ (\w*) $ }sx) { - protect { ($re, $opts) = ($1, $2) }; - } - elsif ($pattern =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx) { - protect { ($re, $opts) = ($2, $3) }; - } - else { - return; - } - - return length $opts ? "(?$opts)$re" : $re; -} - -sub unoverload_str { unoverload(q[""], @_) } - -sub unoverload_num { - unoverload('0+', @_); - - for my $val (@_) { - next unless is_dualvar($$val); - $$val = $$val + 0; - } - - return; -} - -# This is a hack to detect a dualvar such as $! -sub is_dualvar($) { - my($val) = @_; - - # Objects are not dualvars. - return 0 if ref $val; - return 0 unless defined $val; - - no warnings 'numeric'; - my $numval = $val + 0; - return ($numval != 0 and $numval ne $val ? 1 : 0); -} - -## If Scalar::Util is new enough use it -# This breaks cmp_ok diagnostics -#if (my $sub = Scalar::Util->can('isdual')) { -# no warnings 'redefine'; -# *is_dualvar = $sub; -#} - -sub unoverload { - my $type = shift; - - protect { require overload }; - - for my $thing (@_) { - if (blessed $$thing) { - if (my $string_meth = overload::Method($$thing, $type)) { - $$thing = $$thing->$string_meth(); - } - } - } -} - -my $NORMALIZE = undef; -sub translate_filename { - my ($encoding, $orig) = @_; - - return $orig if $encoding eq 'legacy'; - - my $decoded; - require Encode; - try { $decoded = Encode::decode($encoding, "$orig", Encode::FB_CROAK()) }; - return $orig unless $decoded; - - unless (defined $NORMALIZE) { - $NORMALIZE = try { require Unicode::Normalize; 1 }; - $NORMALIZE ||= 0; - } - $decoded = Unicode::Normalize::NFKC($decoded) if $NORMALIZE; - return $decoded || $orig; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Stream::Util - Tools used by Test::Stream and friends. - -=head1 DESCRIPTION - -Collection of tools used by L and friends. - -=head1 EXPORTS - -=over 4 - -=item $success = try { ... } - -=item ($success, $error) = try { ... } - -Eval the codeblock, return success or failure, and optionally the error -message. This code protects $@ and $!, they will be restored by the end of the -run. This code also temporarily blocks $SIG{DIE} handlers. - -=item protect { ... } - -Similar to try, except that it does not catch exceptions. The idea here is to -protect $@ and $! from changes. $@ and $! will be restored to whatever they -were before the run so long as it is successful. If the run fails $! will still -be restored, but $@ will contain the exception being thrown. - -=item spoof([$package, $file, $line], "Code String", @args) - -Eval the string provided as the second argument pretending to be the specified -package, file, and line number. The main purpose of this is to have warnings -and exceptions be thrown from the desired context. - -Additional arguments will be added to an C<@args> variable that is available to -you inside your code string. - -=item $usable_pattern = is_regex($PATTERN) - -Check of the specified argument is a regex. This is mainly important in older -perls where C did not work the way it does now. - -=item is_dualvar - -Do not use this, use Scalar::Util::isdual instead. This is kept around for -legacy support. - -=item unoverload - -=item unoverload_str - -=item unoverload_num - -Legacy tools for unoverloading things. - -=item $proper = translate_filename($encoding, $raw) - -Translate filenames from whatever perl has them stored as into the proper, -specified, encoding. - -=back - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Tester.pm b/cpan/Test-Simple/lib/Test/Tester.pm index 5ac4b58796..a5f1ccfdbb 100644 --- a/cpan/Test-Simple/lib/Test/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Tester.pm @@ -2,335 +2,297 @@ use strict; package Test::Tester; -# Turn this back on later -#warn "Test::Tester is deprecated, see Test::Stream::Tester\n"; +BEGIN +{ + if (*Test::Builder::new{CODE}) + { + warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)" + } +} -use Test::Stream 1.301001 '-internal'; -use Test::Builder 1.301001; -use Test::Stream::Toolset; -use Test::More::Tools; -use Test::Stream qw/-internal STATE_LEGACY/; -use Test::Tester::Capture; +use Test::Builder; +use Test::Tester::CaptureRunner; +use Test::Tester::Delegate; require Exporter; use vars qw( @ISA @EXPORT $VERSION ); -our $VERSION = '1.301001_098'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +$VERSION = "0.114"; +@EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); +@ISA = qw( Exporter ); + +my $Test = Test::Builder->new; +my $Capture = Test::Tester::Capture->new; +my $Delegator = Test::Tester::Delegate->new; +$Delegator->{Object} = $Test; -@EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); -@ISA = qw( Exporter ); +my $runner = Test::Tester::CaptureRunner->new; my $want_space = $ENV{TESTTESTERSPACE}; -sub show_space { - $want_space = 1; +sub show_space +{ + $want_space = 1; } my $colour = ''; -my $reset = ''; +my $reset = ''; -if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR}) { - if (eval "require Term::ANSIColor") { - my ($f, $b) = split(",", $want_colour); - $colour = Term::ANSIColor::color($f) . Term::ANSIColor::color("on_$b"); - $reset = Term::ANSIColor::color("reset"); - } +if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR}) +{ + if (eval "require Term::ANSIColor") + { + my ($f, $b) = split(",", $want_colour); + $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); + $reset = Term::ANSIColor::color("reset"); + } } -my $capture = Test::Tester::Capture->new; -sub capture { $capture } - -sub find_depth { - my ($start, $end); - my $l = 1; - while (my @call = caller($l++)) { - $start = $l if $call[3] =~ m/^Test::Builder::(ok|skip|todo_skip)$/; - next unless $start; - next unless $call[3] eq 'Test::Tester::run_tests'; - $end = $l; - last; - } - - return $Test::Builder::Level + 1 unless defined $start && defined $end; - # 2 the eval and the anon sub - return $end - $start - 2; +sub new_new +{ + return $Delegator; } -require Test::Stream::Event::Ok; -my $META = Test::Stream::ArrayBase::Meta->get('Test::Stream::Event::Ok'); -my $idx = $META->{index} + 1; - -sub run_tests { - my $test = shift; - - my $cstream; - if ($capture) { - $cstream = $capture->{stream}; - } - - my ($stream, $old) = Test::Stream->intercept_start($cstream); - $stream->set_use_legacy(1); - $stream->state->[-1] = [0, 0, undef, 1]; - $stream->munge(sub { - my ($stream, $e) = @_; - $e->[$idx] = find_depth() - $Test::Builder::Level; - $e->[$idx+1] = $Test::Builder::Level; - require Carp; - $e->[$idx + 2] = Carp::longmess(); - }); - - my $level = $Test::Builder::Level; - - my @out; - my $prem = ""; - - my $ok = eval { - $test->(); - - for my $e (@{$stream->state->[-1]->[STATE_LEGACY]}) { - if ($e->isa('Test::Stream::Event::Ok')) { - push @out => $e->to_legacy; - $out[-1]->{name} = '' unless defined $out[-1]->{name}; - $out[-1]->{diag} ||= ""; - $out[-1]->{depth} = $e->[$idx]; - for my $d (@{$e->diag || []}) { - next if $d->message =~ m{Failed (\(TODO\) )?test (.*\n\s*)?at .* line \d+\.}; - next if $d->message =~ m{You named your test '.*'\. You shouldn't use numbers for your test names}; - chomp(my $msg = $d->message); - $msg .= "\n"; - $out[-1]->{diag} .= $msg; - } - } - elsif ($e->isa('Test::Stream::Event::Diag')) { - chomp(my $msg = $e->message); - $msg .= "\n"; - if (!@out) { - $prem .= $msg; - next; - } - next if $msg =~ m{Failed test .*\n\s*at .* line \d+\.}; - $out[-1]->{diag} .= $msg; - } - } - - 1; - }; - my $err = $@; - - $stream->state->[-1] = [0, 0, undef, 1]; - - Test::Stream->intercept_stop($stream); - - die $err unless $ok; - - return ($prem, @out); +sub capture +{ + return Test::Tester::Capture->new; } -sub check_test { - my $test = shift; - my $expect = shift; - my $name = shift; - $name = "" unless defined($name); +sub fh +{ + # experiment with capturing output, I don't like it + $runner = Test::Tester::FHRunner->new; - @_ = ($test, [$expect], $name); - goto &check_tests; + return $Test; } -sub check_tests { - my $test = shift; - my $expects = shift; - my $name = shift; - $name = "" unless defined($name); - - my ($prem, @results) = eval { run_tests($test, $name) }; - - my $ctx = context(); +sub find_run_tests +{ + my $d = 1; + my $found = 0; + while ((not $found) and (my ($sub) = (caller($d))[3]) ) + { +# print "$d: $sub\n"; + $found = ($sub eq "Test::Tester::run_tests"); + $d++; + } + +# die "Didn't find 'run_tests' in caller stack" unless $found; + return $d; +} - my $ok = !$@; - $ctx->ok($ok, "Test '$name' completed"); - $ctx->diag($@) unless $ok; +sub run_tests +{ + local($Delegator->{Object}) = $Capture; - $ok = !length($prem); - $ctx->ok($ok, "Test '$name' no premature diagnostication"); - $ctx->diag("Before any testing anything, your tests said\n$prem") unless $ok; + $runner->run_tests(@_); - cmp_results(\@results, $expects, $name); - return ($prem, @results); + return ($runner->get_premature, $runner->get_results); } -sub cmp_field { - my ($result, $expect, $field, $desc) = @_; +sub check_test +{ + my $test = shift; + my $expect = shift; + my $name = shift; + $name = "" unless defined($name); - my $ctx = context(); - if (defined $expect->{$field}) { - my ($ok, @diag) = Test::More::Tools->is_eq( - $result->{$field}, - $expect->{$field}, - ); - $ctx->ok($ok, "$desc compare $field"); - } + @_ = ($test, [$expect], $name); + goto &check_tests; } -sub cmp_result { - my ($result, $expect, $name) = @_; - - my $ctx = context(); +sub check_tests +{ + my $test = shift; + my $expects = shift; + my $name = shift; + $name = "" unless defined($name); - my $sub_name = $result->{name}; - $sub_name = "" unless defined($name); - - my $desc = "subtest '$sub_name' of '$name'"; - - { - cmp_field($result, $expect, "ok", $desc); + my ($prem, @results) = eval { run_tests($test, $name) }; - cmp_field($result, $expect, "actual_ok", $desc); + $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@); + $Test->ok(! length($prem), "Test '$name' no premature diagnostication") || + $Test->diag("Before any testing anything, your tests said\n$prem"); - cmp_field($result, $expect, "type", $desc); - - cmp_field($result, $expect, "reason", $desc); - - cmp_field($result, $expect, "name", $desc); - } + local $Test::Builder::Level = $Test::Builder::Level + 1; + cmp_results(\@results, $expects, $name); + return ($prem, @results); +} - # if we got no depth then default to 1 - my $depth = 1; - if (exists $expect->{depth}) { - $depth = $expect->{depth}; - } +sub cmp_field +{ + my ($result, $expect, $field, $desc) = @_; - # if depth was explicitly undef then don't test it - if (defined $depth) { - $ctx->ok(1, "depth checking is deprecated, dummy pass result..."); - } + if (defined $expect->{$field}) + { + $Test->is_eq($result->{$field}, $expect->{$field}, + "$desc compare $field"); + } +} - if (defined(my $exp = $expect->{diag})) { - # if there actually is some diag then put a \n on the end if it's not - # there already - - $exp .= "\n" if (length($exp) and $exp !~ /\n$/); - my $ok = $result->{diag} eq $exp; - $ctx->ok( - $ok, - "subtest '$sub_name' of '$name' compare diag" - ); - unless($ok) { - my $got = $result->{diag}; - my $glen = length($got); - my $elen = length($exp); - for ($got, $exp) { - my @lines = split("\n", $_); - $_ = join( - "\n", - map { - if ($want_space) { - $_ = $colour . escape($_) . $reset; - } - else { - "'$colour$_$reset'"; - } - } @lines - ); - } - - $ctx->diag(<{name}; + $sub_name = "" unless defined($name); + + my $desc = "subtest '$sub_name' of '$name'"; + + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + + cmp_field($result, $expect, "ok", $desc); + + cmp_field($result, $expect, "actual_ok", $desc); + + cmp_field($result, $expect, "type", $desc); + + cmp_field($result, $expect, "reason", $desc); + + cmp_field($result, $expect, "name", $desc); + } + + # if we got no depth then default to 1 + my $depth = 1; + if (exists $expect->{depth}) + { + $depth = $expect->{depth}; + } + + # if depth was explicitly undef then don't test it + if (defined $depth) + { + $Test->is_eq($result->{depth}, $depth, "checking depth") || + $Test->diag('You need to change $Test::Builder::Level'); + } + + if (defined(my $exp = $expect->{diag})) + { + # if there actually is some diag then put a \n on the end if it's not + # there already + + $exp .= "\n" if (length($exp) and $exp !~ /\n$/); + if (not $Test->ok($result->{diag} eq $exp, + "subtest '$sub_name' of '$name' compare diag") + ) + { + my $got = $result->{diag}; + my $glen = length($got); + my $elen = length($exp); + for ($got, $exp) + { + my @lines = split("\n", $_); + $_ = join("\n", map { + if ($want_space) + { + $_ = $colour.escape($_).$reset; + } + else + { + "'$colour$_$reset'" + } + } @lines); + } + + $Test->diag(< 32 and $c < 125) or $c == 10) { - $res .= $char; - } - else { - $res .= sprintf('\x{%x}', $c); - } - } - return $res; +sub escape +{ + my $str = shift; + my $res = ''; + for my $char (split("", $str)) + { + my $c = ord($char); + if(($c>32 and $c<125) or $c == 10) + { + $res .= $char; + } + else + { + $res .= sprintf('\x{%x}', $c) + } + } + return $res; } -sub cmp_results { - my ($results, $expects, $name) = @_; - - my $ctx = context(); +sub cmp_results +{ + my ($results, $expects, $name) = @_; - my ($ok, @diag) = Test::More::Tools->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); - $ctx->ok($ok, @diag); + $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); - for (my $i = 0; $i < @$expects; $i++) { - my $expect = $expects->[$i]; - my $result = $results->[$i]; + for (my $i = 0; $i < @$expects; $i++) + { + my $expect = $expects->[$i]; + my $result = $results->[$i]; - cmp_result($result, $expect, $name); - } + local $Test::Builder::Level = $Test::Builder::Level + 1; + cmp_result($result, $expect, $name); + } } ######## nicked from Test::More -sub import { - my $class = shift; - my @plan = @_; - - my $caller = caller; - my $ctx = context(); - - my @imports = (); - foreach my $idx (0 .. $#plan) { - if ($plan[$idx] eq 'import') { - my ($tag, $imports) = splice @plan, $idx, 2; - @imports = @$imports; - last; - } - } +sub plan { + my(@plan) = @_; - my ($directive, $arg) = @plan; - if ($directive eq 'tests') { - $ctx->plan($arg); - } - elsif ($directive) { - $ctx->plan(0, $directive, $arg); - } + my $caller = caller; + + $Test->exported_to($caller); - $class->_export_to_level(1, __PACKAGE__, @imports); + my @imports = (); + foreach my $idx (0..$#plan) { + if( $plan[$idx] eq 'import' ) { + my($tag, $imports) = splice @plan, $idx, 2; + @imports = @$imports; + last; + } + } + + $Test->plan(@plan); + + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); +} + +sub import { + my($class) = shift; + { + no warnings 'redefine'; + *Test::Builder::new = \&new_new; + } + goto &plan; } -sub _export_to_level { - my $pkg = shift; - my $level = shift; - (undef) = shift; # redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); +sub _export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); } + ############ 1; __END__ -=pod - -=encoding UTF-8 - =head1 NAME -Test::Tester - *DEPRECATED* Ease testing test modules built with Test::Builder - -=head1 DEPRECATED - -See L for a modern and maintained alternative. +Test::Tester - Ease testing test modules built with Test::Builder =head1 SYNOPSIS @@ -439,7 +401,7 @@ should allow your test scripts to do and after that any tests inside your module will captured. -=head1 TEST EVENTS +=head1 TEST RESULTS The result of each test is captured in a hash. These hashes are the same as the hashes returned by Test::Builder->details but with a couple of extra @@ -491,10 +453,6 @@ hard to find space and tab related problems. =item depth -B Depth checking is disabled on newer versions of Test::Builder which no -longer uses $Test::Builder::Level. In these versions this will simple produce a -dummy true result. - This allows you to check that your test module is setting the correct value for $Test::Builder::Level and thus giving the correct file and line number when a test fails. It is calculated by looking at caller() and @@ -577,7 +535,7 @@ variable also works (if both are set then the British spelling wins out). =head1 EXPORTED FUNCTIONS -=head2 ($premature, @results) = run_tests(\&test_sub) +=head3 ($premature, @results) = run_tests(\&test_sub) \&test_sub is a reference to a subroutine. @@ -590,7 +548,7 @@ the first test. @results is an array of test result hashes. -=head2 cmp_result(\%result, \%expect, $name) +=head3 cmp_result(\%result, \%expect, $name) \%result is a ref to a test result hash. @@ -600,7 +558,7 @@ cmp_result compares the result with the expected values. If any differences are found it outputs diagnostics. You may leave out any field from the expected result and cmp_result will not do the comparison of that field. -=head2 cmp_results(\@results, \@expects, $name) +=head3 cmp_results(\@results, \@expects, $name) \@results is a ref to an array of test results. @@ -612,7 +570,7 @@ number of elements in \@results and \@expects is the same. Then it goes through each result checking it against the expected result as in cmp_result() above. -=head2 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) +=head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) \&test_sub is a reference to a subroutine. @@ -624,7 +582,7 @@ checks if the tests died at any stage. It returns the same values as run_tests, so you can further examine the test results if you need to. -=head2 ($premature, @results) = check_test(\&test_sub, \%expect, $name) +=head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name) \&test_sub is a reference to a subroutine. @@ -638,7 +596,7 @@ make sure this is true. It returns the same values as run_tests, so you can further examine the test results if you need to. -=head2 show_space() +=head3 show_space() Turn on the escaping of characters as described in the SPACES AND TABS section. @@ -673,100 +631,22 @@ captures the strings output by Test::Builder. This means you cannot get separate access to the individual pieces of information and you must predict B what your test will output. -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester +=head1 AUTHOR This module is copyright 2005 Fergal Daly , some parts are based on other people's work. -Under the same license as Perl itself +Plan handling lifted from Test::More. written by Michael G Schwern +. -See http://www.perl.com/perl/misc/Artistic.html +Test::Tester::Capture is a cut down and hacked up version of Test::Builder. +Test::Builder was written by chromatic and Michael G +Schwern . -=item Test::Builder::Tester +=head1 LICENSE -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. +Under the same license as Perl itself -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. +See http://www.perl.com/perl/misc/Artistic.html -=back +=cut diff --git a/cpan/Test-Simple/lib/Test/Tester/Capture.pm b/cpan/Test-Simple/lib/Test/Tester/Capture.pm index 0fd9f90c4b..00e12e6458 100644 --- a/cpan/Test-Simple/lib/Test/Tester/Capture.pm +++ b/cpan/Test-Simple/lib/Test/Tester/Capture.pm @@ -1,161 +1,231 @@ -package Test::Tester::Capture; use strict; -use warnings; -use base 'Test::Builder'; -use Test::Stream qw/-internal STATE_LEGACY/; +package Test::Tester::Capture; -sub new { - my $class = shift; - my $self = $class->SUPER::create(@_); - $self->{stream}->set_use_tap(0); - $self->{stream}->set_use_legacy(1); - return $self; +use Test::Builder; + +use vars qw( @ISA ); +@ISA = qw( Test::Builder ); + +# Make Test::Tester::Capture thread-safe for ithreads. +BEGIN { + use Config; + if( $] >= 5.008 && $Config{useithreads} ) { + require threads::shared; + threads::shared->import; + } + else { + *share = sub { 0 }; + *lock = sub { 0 }; + } } -sub details { - my $self = shift; - - my $prem; - my @out; - for my $e (@{$self->{stream}->state->[-1]->[STATE_LEGACY]}) { - if ($e->isa('Test::Stream::Event::Ok')) { - push @out => $e->to_legacy; - $out[-1]->{diag} ||= ""; - $out[-1]->{depth} = $e->level; - for my $d (@{$e->diag || []}) { - next if $d->message =~ m{Failed test .*\n\s*at .* line \d+\.}; - chomp(my $msg = $d->message); - $msg .= "\n"; - $out[-1]->{diag} .= $msg; - } - } - elsif ($e->isa('Test::Stream::Event::Diag')) { - chomp(my $msg = $e->message); - $msg .= "\n"; - if (!@out) { - $prem .= $msg; - next; - } - next if $msg =~ m{Failed test .*\n\s*at .* line \d+\.}; - $out[-1]->{diag} .= $msg; - } - } - - return ($prem, @out) if $prem; - return @out; +my $Curr_Test = 0; share($Curr_Test); +my @Test_Results = (); share(@Test_Results); +my $Prem_Diag = {diag => ""}; share($Curr_Test); + +sub new +{ + # Test::Tester::Capgture::new used to just return __PACKAGE__ + # because Test::Builder::new enforced it's singleton nature by + # return __PACKAGE__. That has since changed, Test::Builder::new now + # returns a blessed has and around version 0.78, Test::Builder::todo + # started wanting to modify $self. To cope with this, we now return + # a blessed hash. This is a short-term hack, the correct thing to do + # is to detect which style of Test::Builder we're dealing with and + # act appropriately. + + my $class = shift; + return bless {}, $class; } -1; - -__END__ - -=pod - -=encoding UTF-8 +sub ok { + my($self, $test, $name) = @_; -=head1 NAME - -Test::Tester::Capture - Capture module for TesT::Tester - -=head1 DESCRIPTION + # $test might contain an object which we don't want to accidentally + # store, so we turn it into a boolean. + $test = $test ? 1 : 0; -Legacy support for Test::Tester. + lock $Curr_Test; + $Curr_Test++; -=head1 SOURCE + my($pack, $file, $line) = $self->caller; -The source code repository for Test::More can be found at -F. + my $todo = $self->todo($pack); -=head1 MAINTAINER + my $result = {}; + share($result); -=over 4 + unless( $test ) { + @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); + } + else { + @$result{ 'ok', 'actual_ok' } = ( 1, $test ); + } -=item Chad Granum Eexodist@cpan.orgE + if( defined $name ) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $result->{name} = $name; + } + else { + $result->{name} = ''; + } -=back + if( $todo ) { + my $what_todo = $todo; + $result->{reason} = $what_todo; + $result->{type} = 'todo'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } -=head1 AUTHORS + $Test_Results[$Curr_Test-1] = $result; -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). + unless( $test ) { + my $msg = $todo ? "Failed (TODO)" : "Failed"; + $result->{fail_diag} = (" $msg test ($file at line $line)\n"); + } -=over 4 + $result->{diag} = ""; + $result->{_level} = $Test::Builder::Level; + $result->{_depth} = Test::Tester::find_run_tests(); -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE + return $test ? 1 : 0; +} -=item Michael G Schwern Eschwern@pobox.comE +sub skip { + my($self, $why) = @_; + $why ||= ''; + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => $why, + diag => "", + _level => $Test::Builder::Level, + _depth => Test::Tester::find_run_tests(), + ); + $Test_Results[$Curr_Test-1] = \%result; + + return 1; +} -=item 唐鳳 +sub todo_skip { + my($self, $why) = @_; + $why ||= ''; + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + diag => "", + _level => $Test::Builder::Level, + _depth => Test::Tester::find_run_tests(), + ); + + $Test_Results[$Curr_Test-1] = \%result; + + return 1; +} -=back +sub diag { + my($self, @msgs) = @_; + return unless @msgs; -=head1 COPYRIGHT + # Prevent printing headers when compiling (i.e. -c) + return if $^C; -There has been a lot of code migration between modules, -here are all the original copyrights together: + # Escape each line with a #. + foreach (@msgs) { + $_ = 'undef' unless defined; + } -=over 4 + push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; -=item Test::Stream + my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; -=item Test::Stream::Tester + $result->{diag} .= join("", @msgs); -Copyright 2014 Chad Granum Eexodist7@gmail.comE. + return 0; +} -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. +sub details { + return @Test_Results; +} -See F -=item Test::Simple +# Stub. Feel free to send me a patch to implement this. +sub note { +} -=item Test::More +sub explain { + return Test::Builder::explain(@_); +} -=item Test::Builder +sub premature +{ + return $Prem_Diag->{diag}; +} -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. +sub current_test +{ + if (@_ > 1) + { + die "Don't try to change the test number!"; + } + else + { + return $Curr_Test; + } +} -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. +sub reset +{ + $Curr_Test = 0; + @Test_Results = (); + $Prem_Diag = {diag => ""}; +} -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. +1; -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. +__END__ -See F +=head1 NAME -=item Test::use::ok +Test::Tester::Capture - Help testing test modules built with Test::Builder -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. +=head1 DESCRIPTION -This work is published from Taiwan. +This is a subclass of Test::Builder that overrides many of the methods so +that they don't output anything. It also keeps track of it's own set of test +results so that you can use Test::Builder based modules to perform tests on +other Test::Builder based modules. -L +=head1 AUTHOR -=item Test::Tester +Most of the code here was lifted straight from Test::Builder and then had +chunks removed by Fergal Daly . -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. +=head1 LICENSE Under the same license as Perl itself See http://www.perl.com/perl/misc/Artistic.html -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back +=cut diff --git a/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm b/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm index a9815328a5..f14a4c145a 100644 --- a/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm +++ b/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm @@ -1,19 +1,76 @@ +# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $ use strict; -use warnings; + package Test::Tester::CaptureRunner; -warn "Test::Tester::CaptureRunner is deprecated"; +use Test::Tester::Capture; +require Exporter; + +sub new +{ + my $pkg = shift; + my $self = bless {}, $pkg; + return $self; +} + +sub run_tests +{ + my $self = shift; + + my $test = shift; + + capture()->reset; + + $self->{StartLevel} = $Test::Builder::Level; + &$test(); +} + +sub get_results +{ + my $self = shift; + my @results = capture()->details; + + my $start = $self->{StartLevel}; + foreach my $res (@results) + { + next if defined $res->{depth}; + my $depth = $res->{_depth} - $res->{_level} - $start - 3; +# print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n"; + $res->{depth} = $depth; + } -1; + return @results; +} + +sub get_premature +{ + return capture()->premature; +} + +sub capture +{ + return Test::Tester::Capture->new; +} __END__ =head1 NAME -Test::Tester::CaptureRunner - Deprecated +Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder =head1 DESCRIPTION -DEPRECATED. This package is now just a stub. +This stuff if needed to allow me to play with other ways of monitoring the +test results. + +=head1 AUTHOR + +Copyright 2003 by Fergal Daly . + +=head1 LICENSE + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html =cut diff --git a/cpan/Test-Simple/lib/Test/Tester/Delegate.pm b/cpan/Test-Simple/lib/Test/Tester/Delegate.pm index f25070e455..7ddb921cdf 100644 --- a/cpan/Test-Simple/lib/Test/Tester/Delegate.pm +++ b/cpan/Test-Simple/lib/Test/Tester/Delegate.pm @@ -1,19 +1,32 @@ use strict; use warnings; + package Test::Tester::Delegate; -warn "Test::Tester::Delegate is deprecated"; +use vars '$AUTOLOAD'; -1; +sub new +{ + my $pkg = shift; -__END__ + my $obj = shift; + my $self = bless {}, $pkg; -=head1 NAME + return $self; +} -Test::Tester::Delegate - Deprecated +sub AUTOLOAD +{ + my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/; -=head1 DESCRIPTION + return if $sub eq "DESTROY"; -DEPRECATED. This package is now just a stub. + my $obj = $_[0]->{Object}; -=cut + my $ref = $obj->can($sub); + shift(@_); + unshift(@_, $obj); + goto &$ref; +} + +1; diff --git a/cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod b/cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod deleted file mode 100644 index 9f367c067c..0000000000 --- a/cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod +++ /dev/null @@ -1,198 +0,0 @@ -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Tutorial::WritingTests - A Complete Introduction to writing tests - -=head1 What are tests? - -Tests are code that verifies other code produces the expected output for a -given input. An example may help: - - # This code will die if math doesbn't work. - die "Math is broken" unless 1 + 1 == 2; - -However it is better to use a framework intended for testing: - - ok( 1 + 1 == 2, "Math Works" ); - -This will tell you if the test passes or fails, and will give you extra -information like the name of the test, and what line it was written on if it -fails. - -=head1 Simple example. - - use Test::More; - - ok( 1, "1 is true, this test will pass" ); - ok( 0, "0 is false, this test will fail" ); - - is( 1 + 1, 2, "1 + 1 == 2" ); - - my @array = first_3_numbers(); - - is_deeply( - \@array, - [ 1, 2, 3 ], - "function returned an array of 3 numbers" - ); - - # When you are done, call this to satisfy the plan - done_testing - -See L for C, C, C, and several other -useful tools. - -=head1 What is a plan? - -You need to declare how many tests should be seen, this is to ensure your test -does not die partway through. There are 2 ways to declare a plan, 1 way to -decline to make a plan, and a way to skip everything. - -=over 4 - -=item done_testing - - use Test::More; - - ok(1, "pass"); - - done_testing; - -Using done_testing means you do not need to update the plan every time you -change your test script. - -=item Test count - -At import: - - use Test::More tests => 1; - ok(1, "pass"); - -Plan on its own: - - use Test::More; - plan tests => 1; - ok(1, "pass"); - -=item No Plan - - use Test::More 'no_plan'; - -No plan, no way to verify everything ran. - -=item skip_all - - use Test::More skip_all => "We won't run these now"; - -Just don't do anything. - -=back - -=head1 See Also - -L - -=head1 Writing tools. - -See L - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod b/cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod deleted file mode 100644 index 97c14d19ab..0000000000 --- a/cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod +++ /dev/null @@ -1,300 +0,0 @@ -=pod - -=encoding UTF-8 - -=head1 NAME - -Test::Tutorial::WritingTools - How to write testing tools. - -=head1 Examples - -=over 4 - -=item Complete Example - - package My::Tool; - use strict; - use warnings; - - use Test::Stream::Toolset; - use Test::Stream::Exporter; - - # Export 'validate_widget' by default. - default_exports qw/validate_widget/; - - sub validate_widget { - my ($widget, $produces, $name) = @_; - my $ctx = context(); # Do this early as possible - - my $value = $widget->produce; - my $ok = $value eq $produces; - - if ($ok) { - # On success generate an ok event - $ctx->ok($ok, $name); - } - else { - # On failure generate an OK event with some diagnostics - $ctx->ok($ok, $name, ["Widget produced '$value'\n Wanted '$produces'"]); - } - - # It is usually polite to return a true/false value. - return $ok ? 1 : 0; - } - - 1; - -=item Alternate using Exporter.pm - - package My::Tool; - use strict; - use warnings; - - use Test::Stream::Toolset; - - # Export 'validate_widget' by default. - use base 'Exporter'; - our @EXPORT = qw/validate_widget/; - - sub validate_widget { - my ($widget, $produces, $name) = @_; - my $ctx = context(); # Do this early as possible - - my $value = $widget->produce; - my $ok = $value eq $produces; - - if ($ok) { - # On success generate an ok event - $ctx->ok($ok, $name); - } - else { - # On failure generate an OK event with some diagnostics - $ctx->ok($ok, $name, ["Widget produced '$value'\n Wanted '$produces'"]); - } - - # It is usually polite to return a true/false value. - return $ok ? 1 : 0; - } - - 1; - -=back - -=head2 Explanation - -L is event based. Whenever you want to produce a result you will -generate an event for it. The most common event is L. -Events require some extra information such as where and how they were produced. -In general you do not need to worry about these extra details, they can be -filled in by C. - -To get a context object you call C which can be imported from -L itself, or from L. Once you -have a context object you can ask it to issue events for you. All event types -C get helper methods on the context object. - -=head2 IMPORTANT NOTE ON CONTEXTS - -The context object has some magic to it. Essentially it is a semi-singleton. -That is if you generate a context object in one place, then try to generate -another one in another place, you will just get the first one again so long as -it still has a reference. If however the first one has fallen out of scope or -been undefined, a new context is generated. - -The idea here is that if you nest functions that use contexts, all levels of -depth will get the same initial context. On the other hand 2 functions run in -sequence will get independant context objects. What this means is that you -should NEVER store a context object in a package variable or object attribute. -You should also never assign it to a variable in a higher scope. - -C assumes you are at the lowest level of your tool, and looks at the -current caller. If you need it to look further you can call it with a numeric -argument which is added to the level. To clarify, calling C is the -same as calling C. - -=head1 Nesting calls to other tools - - use Test::More; - use Test::Stream::Toolset; - - sub compound_check { - my ($object, $name) = @_; - - # Grab the context now for nested tools to find - my $ctx = context; - - my $ok = $object ? 1 : 0; - $ok &&= isa_ok($object, 'Some::Class'); - $ok &&= can_ok($object, qw/foo bar baz/); - $ok &&= is($object->foo, 'my foo', $name); - - $ctx->ok($ok, $name, $ok ? () : ['Not all object checks passed!']); - - return $ok; - } - - 1; - -Nesting tools just works as expected so long as you grab the context BEFORE you -call them. Errors will be reported to the correct file and line number. - -=head1 Useful toolsets to look at - -=over 4 - -=item L - -This is the collection of tools used by L under the hood. You can -use these instead of L exports to duplicate functionality without -generating extra events. - -=back - -=head1 Available Events - -Anyone can add an event by shoving it in the C -namespace. It will autoload if C<< $context->event_name >> is called. But here -is the list of events that come with L. - -=over 4 - -=item L - - $ctx->ok($bool, $name); - $ctx->ok($bool, $name, \@diag); - -Generate an Ok event. - -=item L - - $ctx->diag("Diag Message"); - -Generate a diagniostics (stderr) message - -=item L - - $ctx->note("Note Message"); - -Generate a note (stdout) message - -=item L - - $ctx->bail("Reason we are bailing"); - -Stop the entire test file, something is very wrong! - -=item L - - $ctx->plan($max); - $ctx->plan(0, $directive, $reason); - -Set the plan. - -=back - -=head1 Testing your tools - -See L, which lets you intercept and validate events. - -B C and C which are both -deprecated. They were once the way everyone tested their testers, but they do -not allow you to test all events, and they are very fragile when upstream libs -change. - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok - -To the extent possible under law, 唐鳳 has waived all copyright and related -or neighboring rights to L. - -This work is published from Taiwan. - -L - -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back diff --git a/cpan/Test-Simple/lib/Test/use/ok.pm b/cpan/Test-Simple/lib/Test/use/ok.pm index c9e19ed720..87d7cc52a5 100644 --- a/cpan/Test-Simple/lib/Test/use/ok.pm +++ b/cpan/Test-Simple/lib/Test/use/ok.pm @@ -1,20 +1,9 @@ package Test::use::ok; -use strict; -use warnings; use 5.005; +$Test::use::ok::VERSION = '0.16'; -our $VERSION = '1.301001_098'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) - -use Test::Stream 1.301001 '-internal'; - -1; __END__ -=pod - -=encoding UTF-8 - =head1 NAME Test::use::ok - Alternative to Test::More::use_ok @@ -25,9 +14,9 @@ Test::use::ok - Alternative to Test::More::use_ok =head1 DESCRIPTION -According to the B documentation, it used to be recommended to run -C inside a C block, so functions are exported at compile-time -and prototypes are properly honored. +According to the B documentation, it is recommended to run +C inside a C block, so functions are exported at +compile-time and prototypes are properly honored. That is, instead of writing this: @@ -51,11 +40,6 @@ makes it clear that this is a single compile-time action. L -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - =head1 MAINTAINER =over 4 @@ -64,65 +48,9 @@ F. =back -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream +=encoding utf8 -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok +=head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L. @@ -131,22 +59,4 @@ This work is published from Taiwan. L -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back - =cut diff --git a/cpan/Test-Simple/lib/ok.pm b/cpan/Test-Simple/lib/ok.pm index 653eb491a0..02726ac964 100644 --- a/cpan/Test-Simple/lib/ok.pm +++ b/cpan/Test-Simple/lib/ok.pm @@ -1,34 +1,25 @@ package ok; -use strict; -use warnings; - -use Test::Stream 1.301001 '-internal'; -use Test::More 1.301001 (); -use Test::Stream::Carp qw/croak/; +$ok::VERSION = '0.16'; -our $VERSION = '1.301001_098'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +use strict; +use Test::More (); sub import { shift; if (@_) { - croak "'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable?" - unless defined $_[0]; - goto &Test::More::pass if $_[0] eq 'ok'; goto &Test::More::use_ok; } + + # No argument list - croak as if we are prototyped like use_ok() + my (undef, $file, $line) = caller(); + ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n"; } -1; __END__ -=pod - -=encoding UTF-8 - =head1 NAME ok - Alternative to Test::More::use_ok @@ -44,78 +35,7 @@ and they will be executed at C time. Please see L for the full description. -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - -=head1 MAINTAINER - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -The following people have all contributed to the Test-More dist (sorted using -VIM's sort function). - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=item Fergal Daly Efergal@esatclear.ie>E - -=item Mark Fowler Emark@twoshortplanks.comE - -=item Michael G Schwern Eschwern@pobox.comE - -=item 唐鳳 - -=back - -=head1 COPYRIGHT - -There has been a lot of code migration between modules, -here are all the original copyrights together: - -=over 4 - -=item Test::Stream - -=item Test::Stream::Tester - -Copyright 2014 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::Simple - -=item Test::More - -=item Test::Builder - -Originally authored by Michael G Schwern Eschwern@pobox.comE with much -inspiration from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa -gang. - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=item Test::use::ok +=head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L. @@ -124,20 +44,4 @@ This work is published from Taiwan. L -=item Test::Tester - -This module is copyright 2005 Fergal Daly , some parts -are based on other people's work. - -Under the same license as Perl itself - -See http://www.perl.com/perl/misc/Artistic.html - -=item Test::Builder::Tester - -Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. - -This program is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=back +=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 < 3; +use ok 'strict'; +use ok 'Test::More'; +use ok 'ok'; diff --git a/cpan/Test-Simple/t/478-cmp_ok_hash.t b/cpan/Test-Simple/t/478-cmp_ok_hash.t new file mode 100644 index 0000000000..811835b9d3 --- /dev/null +++ b/cpan/Test-Simple/t/478-cmp_ok_hash.t @@ -0,0 +1,41 @@ +use strict; +use warnings; +use Test::More; + + +my $want = 0; +my $got = 0; + +cmp_ok($got, 'eq', $want, "Passes on correct comparison"); + +my ($res, @ok, @diag, @warn); +{ + no warnings 'redefine'; + local *Test::Builder::ok = sub { + my ($tb, $ok, $name) = @_; + push @ok => $ok; + return $ok; + }; + local *Test::Builder::diag = sub { + my ($tb, @d) = @_; + push @diag => @d; + }; + local $SIG{__WARN__} = sub { + push @warn => @_; + }; + $res = cmp_ok($got, '#eq', $want, "You shall not pass!"); +} + +ok(!$res, "Did not pass"); + +is(@ok, 1, "1 result"); +ok(!$ok[0], "result is false"); + +# We only care that it mentions a syntax error. +like(join("\n" => @diag), qr/syntax error at \(eval in cmp_ok\)/, "Syntax error"); + +# We are not going to inspect the warning because it is not super predictable, +# and changes with eval specifics. +ok(@warn, "We got warnings"); + +done_testing; 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/Behavior/388-threadedsubtest.load b/cpan/Test-Simple/t/Behavior/388-threadedsubtest.load deleted file mode 100644 index ee341250e8..0000000000 --- a/cpan/Test-Simple/t/Behavior/388-threadedsubtest.load +++ /dev/null @@ -1,3 +0,0 @@ -use Test::More; -ok(1,"name"); -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/388-threadedsubtest.t b/cpan/Test-Simple/t/Behavior/388-threadedsubtest.t deleted file mode 100644 index fae3783f0e..0000000000 --- a/cpan/Test-Simple/t/Behavior/388-threadedsubtest.t +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/perl -use strict; -use warnings; - -use Test::CanThread qw/AUTHOR_TESTING/; -use Test::More; - -subtest my_subtest => sub { - my $file = __FILE__; - $file =~ s/\.t$/.load/; - do $file || die $@; -}; - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/478-cmp_ok_hash.t b/cpan/Test-Simple/t/Behavior/478-cmp_ok_hash.t deleted file mode 100644 index ae82249caf..0000000000 --- a/cpan/Test-Simple/t/Behavior/478-cmp_ok_hash.t +++ /dev/null @@ -1,36 +0,0 @@ -use strict; -use warnings; -use Test::More; - -use Test::Stream::Tester; - -my $want = 0; -my $got = 0; - -cmp_ok($got, 'eq', $want, "Passes on correct comparison"); - -my @warn; -my $events = intercept { - no warnings 'redefine'; - local $SIG{__WARN__} = sub { - push @warn => @_; - }; - cmp_ok($got, '#eq', $want, "You shall not pass!"); -}; - -# We are not going to inspect the warning because it is not super predictable, -# and changes with eval specifics. -ok(@warn, "We got warnings"); - -events_are( - $events, - check { - event ok => { - bool => 0, - diag => qr/syntax error at \(eval in cmp_ok\)/, - }; - }, - "Events meet expectations" -); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/490-inherit_exporter.t b/cpan/Test-Simple/t/Behavior/490-inherit_exporter.t deleted file mode 100644 index b899bfecd0..0000000000 --- a/cpan/Test-Simple/t/Behavior/490-inherit_exporter.t +++ /dev/null @@ -1,25 +0,0 @@ -use strict; -use warnings; - - -BEGIN { - $INC{'My/Tester.pm'} = __FILE__; - package My::Tester; - use Test::More; - use base 'Test::More'; - - our @EXPORT = (@Test::More::EXPORT, qw/foo/); - our @EXPORT_OK = (@Test::More::EXPORT_OK); - - sub foo { goto &Test::More::ok } - - 1; -} - -use My::Tester; - -can_ok(__PACKAGE__, qw/ok done_testing foo/); - -foo(1, "This is just an ok"); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/CustomOutput.t b/cpan/Test-Simple/t/Behavior/CustomOutput.t deleted file mode 100644 index e4d7185809..0000000000 --- a/cpan/Test-Simple/t/Behavior/CustomOutput.t +++ /dev/null @@ -1,137 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; -use Scalar::Util qw/blessed/; - -# This will replace the main Test::Stream object for the scope of the coderef. -# We apply our output changes only in that scope so that this test itself can -# verify things with regular TAP output. The things done inside thise sub would -# work just fine when used by any module to alter the output. - -my @OUTPUT; -Test::Stream->intercept(sub { - # Turn off normal TAP output - Test::Stream->shared->set_use_tap(0); - - # Turn off legacy storage of results. - Test::Stream->shared->set_use_legacy(0); - - Test::Stream->shared->listen(sub { - my ($stream, $event) = @_; - - push @OUTPUT => "We got an event of type " . blessed($event); - }); - - # Now we run some tests, no TAP will be produced, instead all events will - # be added to @OUTPUT. - - ok(1, "pass"); - ok(0, "fail"); - - subtest foo => sub { - ok(1, "pass"); - ok(0, "fail"); - }; - - diag "Hello"; -}); - -is_deeply( - \@OUTPUT, - [ - 'We got an event of type Test::Stream::Event::Ok', - 'We got an event of type Test::Stream::Event::Ok', - 'We got an event of type Test::Stream::Event::Note', - 'We got an event of type Test::Stream::Event::Subtest', - 'We got an event of type Test::Stream::Event::Diag', - ], - "Got all events" -); - -# Now for something more complicated, lets have everything be normal TAP, -# except subtests - -my (@STDOUT, @STDERR, @TODO); -my @IO = (\@STDOUT, \@STDERR, \@TODO); - -Test::Stream->intercept(sub { - # Turn off normal TAP output - Test::Stream->shared->set_use_tap(0); - - # Turn off legacy storage of results. - Test::Stream->shared->set_use_legacy(0); - - my $number = 1; - Test::Stream->shared->listen(sub { - my ($stream, $e) = @_; - - # Do not output results inside subtests - return if $e->in_subtest; - - return unless $e->can('to_tap'); - - my $num = $stream->use_numbers ? $number++ : undef; - - # Get the TAP for the event - my @sets; - if ($e->isa('Test::Stream::Event::Subtest')) { - # Subtest is a subclass of Ok, use Ok's to_tap method: - @sets = Test::Stream::Event::Ok::to_tap($e, $num); - # Here you can also add whatever output you want. - } - else { - @sets = $e->to_tap($num); - } - - for my $set (@sets) { - my ($hid, $msg) = @$set; - next unless $msg; - my $enc = $e->encoding || die "Could not find encoding!"; - - # This is how you get the proper handle to use (STDERR, STDOUT, ETC). - my $io = $stream->io_sets->{$enc}->[$hid] || die "Could not find IO $hid for $enc"; - $io = $IO[$hid]; - - # Make sure we don't alter these vars. - local($\, $", $,) = (undef, ' ', ''); - - # Normally you print to the IO, but here we are pushing to arrays - chomp($msg); - push @$io => $msg; - } - }); - - # Now we run some tests, no TAP will be produced, instead all events will - # be added to our ourputs - - ok(1, "pass"); - ok(0, "fail"); - - subtest foo => sub { - ok(1, "pass"); - ok(0, "fail"); - }; - - diag "Hello"; -}); - -is(@TODO, 0, "No TODO output"); - -is_deeply( - \@STDOUT, - [ - 'ok 1 - pass', - 'not ok 2 - fail', - '# Subtest: foo', - # As planned, none of the events inside the subtest got rendered. - 'not ok 4 - foo' - ], - "Got expected TAP" -); - -is(pop(@STDERR), "# Hello", "Got the hello diag"); -is(@STDERR, 2, "got diag for 2 failed tests"); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/MonkeyPatching_diag.t b/cpan/Test-Simple/t/Behavior/MonkeyPatching_diag.t deleted file mode 100644 index e89f02cc97..0000000000 --- a/cpan/Test-Simple/t/Behavior/MonkeyPatching_diag.t +++ /dev/null @@ -1,106 +0,0 @@ -use strict; -use warnings; -use B; - -use Test::Stream; -use Test::MostlyLike; -use Test::More tests => 3; -use Test::Builder; # Not loaded by default in modern mode -my $orig = Test::Builder->can('diag'); - -{ - package MyModernTester; - use Test::More; - use Test::Stream; - use Test::MostlyLike; - use Test::Stream::Tester qw/intercept/; - - no warnings 'redefine'; - local *Test::Builder::diag = sub { - my $self = shift; - return $self->$orig(__PACKAGE__ . ": ", @_); - }; - use warnings; - - my $file = __FILE__; - # Line number is tricky, just use what B says The sub may not actually think it - # is on the line it is may be off by 1. - my $line = B::svref_2object(\&Test::Builder::diag)->START->line; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - intercept { - diag('first'); - diag('seconds'); - }; - } - mostly_like( - \@warnings, - [ - qr{The new sub is 'MyModernTester::__ANON__' defined in \Q$file\E around line $line}, - undef, #Only 1 warning - ], - "Found expected warning, just the one" - ); -} - -{ - package MyModernTester2; - use Test::More; - use Test::Stream; - use Test::MostlyLike; - use Test::Stream::Tester qw/intercept/; - - no warnings 'redefine'; - local *Test::Builder::diag = sub { - my $self = shift; - return $self->$orig(__PACKAGE__ . ": ", @_); - }; - use warnings; - - my $file = __FILE__; - # Line number is tricky, just use what B says The sub may not actually think it - # is on the line it is may be off by 1. - my $line = B::svref_2object(\&Test::Builder::diag)->START->line; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - intercept { - diag('first'); - diag('seconds'); - }; - } - mostly_like( - \@warnings, - [ - qr{The new sub is 'MyModernTester2::__ANON__' defined in \Q$file\E around line $line}, - undef, #Only 1 warning - ], - "new override, new warning" - ); -} - -{ - package MyLegacyTester; - use Test::More; - use Test::Stream::Tester qw/intercept/; - - no warnings 'redefine'; - local *Test::Builder::diag = sub { - my $self = shift; - return $self->$orig(__PACKAGE__ . ": ", @_); - }; - use warnings; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - intercept { - diag('first'); - diag('seconds'); - }; - } - is(@warnings, 0, "no warnings for a legacy tester"); -} diff --git a/cpan/Test-Simple/t/Behavior/MonkeyPatching_done_testing.t b/cpan/Test-Simple/t/Behavior/MonkeyPatching_done_testing.t deleted file mode 100644 index 8c62100d07..0000000000 --- a/cpan/Test-Simple/t/Behavior/MonkeyPatching_done_testing.t +++ /dev/null @@ -1,61 +0,0 @@ -use strict; -use warnings; -use B; - -use Test::Stream; -use Test::MostlyLike; -use Test::More tests => 4; -use Test::Builder; # Not loaded by default in modern mode -my $orig = Test::Builder->can('done_testing'); - -use Test::Stream::Tester; - -my $ran = 0; -no warnings 'redefine'; -my $file = __FILE__; -my $line = __LINE__ + 1; -*Test::Builder::done_testing = sub { my $self = shift; $ran++; $self->$orig(@_) }; -use warnings; - -my @warnings; -$SIG{__WARN__} = sub { push @warnings => @_ }; - -events_are( - intercept { - ok(1, "pass"); - ok(0, "fail"); - - done_testing; - }, - check { - event ok => { bool => 1 }; - event ok => { bool => 0 }; - event plan => { max => 2 }; - directive 'end'; - }, -); - -events_are( - intercept { - ok(1, "pass"); - ok(0, "fail"); - - done_testing; - }, - check { - event ok => { bool => 1 }; - event ok => { bool => 0 }; - event plan => { max => 2 }; - directive 'end'; - }, -); - -is($ran, 2, "We ran our override both times"); -mostly_like( - \@warnings, - [ - qr{The new sub is 'main::__ANON__' defined in \Q$file\E around line $line}, - undef, - ], - "Got the warning once" -); diff --git a/cpan/Test-Simple/t/Behavior/MonkeyPatching_note.t b/cpan/Test-Simple/t/Behavior/MonkeyPatching_note.t deleted file mode 100644 index 7c8e765629..0000000000 --- a/cpan/Test-Simple/t/Behavior/MonkeyPatching_note.t +++ /dev/null @@ -1,97 +0,0 @@ -use strict; -use warnings; -use B; - -use Test::Stream; -use Test::MostlyLike; -use Test::More tests => 3; -use Test::Builder; # Not loaded by default in modern mode -my $orig = Test::Builder->can('note'); - -{ - package MyModernTester; - use Test::More; - use Test::Stream; - use Test::MostlyLike; - - no warnings 'redefine'; - local *Test::Builder::note = sub { - my $self = shift; - return $self->$orig(__PACKAGE__ . ": ", @_); - }; - use warnings; - - my $file = __FILE__; - # Line number is tricky, just use what B says The sub may not actually think it - # is on the line it is may be off by 1. - my $line = B::svref_2object(\&Test::Builder::note)->START->line; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - note('first'); - note('seconds'); - } - mostly_like( - \@warnings, - [ - qr{The new sub is 'MyModernTester::__ANON__' defined in \Q$file\E around line $line}, - undef, #Only 1 warning - ], - "Found expected warning, just the one" - ); -} - -{ - package MyModernTester2; - use Test::More; - use Test::Stream; - use Test::MostlyLike; - - no warnings 'redefine'; - local *Test::Builder::note = sub { - my $self = shift; - return $self->$orig(__PACKAGE__ . ": ", @_); - }; - use warnings; - - my $file = __FILE__; - # Line number is tricky, just use what B says The sub may not actually think it - # is on the line it is may be off by 1. - my $line = B::svref_2object(\&Test::Builder::note)->START->line; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - note('first'); - note('seconds'); - } - mostly_like( - \@warnings, - [ - qr{The new sub is 'MyModernTester2::__ANON__' defined in \Q$file\E around line $line}, - undef, #Only 1 warning - ], - "new override, new warning" - ); -} - -{ - package MyLegacyTester; - use Test::More; - - no warnings 'redefine'; - local *Test::Builder::note = sub { - my $self = shift; - return $self->$orig(__PACKAGE__ . ": ", @_); - }; - use warnings; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - note('first'); - note('seconds'); - } - is(@warnings, 0, "no warnings for a legacy tester"); -} diff --git a/cpan/Test-Simple/t/Behavior/MonkeyPatching_ok.t b/cpan/Test-Simple/t/Behavior/MonkeyPatching_ok.t deleted file mode 100644 index faf92bfc45..0000000000 --- a/cpan/Test-Simple/t/Behavior/MonkeyPatching_ok.t +++ /dev/null @@ -1,108 +0,0 @@ -use strict; -use warnings; -use B; - -use Test::Stream; -use Test::MostlyLike; -use Test::More tests => 9; -use Test::Builder; # Not loaded by default in modern mode -my $orig = Test::Builder->can('ok'); - -{ - package MyModernTester; - use Test::Stream; - use Test::MostlyLike; - use Test::More; - - no warnings 'redefine'; - local *Test::Builder::ok = sub { - my $self = shift; - my ($bool, $name) = @_; - $name = __PACKAGE__ . ": $name"; - return $self->$orig($bool, $name); - }; - use warnings; - - my $file = __FILE__; - # Line number is tricky, just use what B says The sub may not actually think it - # is on the line it is may be off by 1. - my $line = B::svref_2object(\&Test::Builder::ok)->START->line; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - ok(1, "fred"); - ok(2, "barney"); - } - mostly_like( - \@warnings, - [ - qr{The new sub is 'MyModernTester::__ANON__' defined in \Q$file\E around line $line}, - undef, #Only 1 warning - ], - "Found expected warning, just the one" - ); -} - -{ - package MyModernTester2; - use Test::Stream; - use Test::MostlyLike; - use Test::More; - - no warnings 'redefine'; - local *Test::Builder::ok = sub { - my $self = shift; - my ($bool, $name) = @_; - $name = __PACKAGE__ . ": $name"; - return $self->$orig($bool, $name); - }; - use warnings; - - my $file = __FILE__; - # Line number is tricky, just use what B says The sub may not actually think it - # is on the line it is may be off by 1. - my $line = B::svref_2object(\&Test::Builder::ok)->START->line; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - ok(1, "fred"); - ok(2, "barney"); - } - mostly_like( - \@warnings, - [ - qr{The new sub is 'MyModernTester2::__ANON__' defined in \Q$file\E around line $line}, - undef, #Only 1 warning - ], - "new override, new warning" - ); -} - -{ - package MyLegacyTester; - use Test::More; - - no warnings 'redefine'; - local *Test::Builder::ok = sub { - my $self = shift; - my ($bool, $name) = @_; - $name = __PACKAGE__ . ": $name"; - return $self->$orig($bool, $name); - }; - use warnings; - - my $file = __FILE__; - # Line number is tricky, just use what B says The sub may not actually think it - # is on the line it is may be off by 1. - my $line = B::svref_2object(\&Test::Builder::ok)->START->line; - - my @warnings; - { - local $SIG{__WARN__} = sub { push @warnings => @_ }; - ok(1, "fred"); - ok(2, "barney"); - } - is(@warnings, 0, "no warnings for a legacy tester"); -} diff --git a/cpan/Test-Simple/t/Behavior/MonkeyPatching_plan.t b/cpan/Test-Simple/t/Behavior/MonkeyPatching_plan.t deleted file mode 100644 index 236a083cbf..0000000000 --- a/cpan/Test-Simple/t/Behavior/MonkeyPatching_plan.t +++ /dev/null @@ -1,115 +0,0 @@ -use strict; -use warnings; -use B; - -use Test::Stream; -use Test::MostlyLike; -use Test::More tests => 8; -use Test::Builder; # Not loaded by default in modern mode -my $orig = Test::Builder->can('plan'); - -use Test::Stream::Tester; - -my $ran = 0; -no warnings 'redefine'; -my $file = __FILE__; -my $line = __LINE__ + 1; -*Test::Builder::plan = sub { my $self = shift; $ran++; $self->$orig(@_) }; -use warnings; - -my @warnings; -$SIG{__WARN__} = sub { push @warnings => @_ }; - -events_are( - intercept { - plan tests => 2; - ok(1, "pass"); - ok(0, "fail"); - }, - check { - event plan => { max => 2 }; - event ok => { bool => 1 }; - event ok => { bool => 0 }; - directive 'end'; - }, -); - -events_are( - intercept { - Test::More->import('tests' => 2); - ok(1, "pass"); - ok(0, "fail"); - }, - check { - event plan => { max => 2 }; - event ok => { bool => 1 }; - event ok => { bool => 0 }; - directive 'end'; - }, -); - -events_are( - intercept { - Test::More->import(skip_all => 'damn'); - ok(1, "pass"); - ok(0, "fail"); - }, - check { - event plan => { max => 0, directive => 'SKIP', reason => 'damn' }; - directive 'end'; - }, -); - -events_are( - intercept { - Test::More->import('no_plan'); - ok(1, "pass"); - ok(0, "fail"); - }, - check { - event plan => { directive => 'NO PLAN' }; - event ok => { bool => 1 }; - event ok => { bool => 0 }; - directive 'end'; - }, -); - -is($ran, 4, "We ran our override each time"); -mostly_like( - \@warnings, - [ - qr{The new sub is 'main::__ANON__' defined in \Q$file\E around line $line}, - undef, - ], - "Got the warning once" -); - - - -no warnings 'redefine'; -*Test::Builder::plan = sub { }; -use warnings; -my $ok; -events_are( - intercept { - $ok = eval { - plan(tests => 1); - plan(tests => 2); - ok(1); - ok(1); - ok(1); - done_testing; - 1; - }; - }, - check { - event ok => { bool => 1 }; - event ok => { bool => 1 }; - event ok => { bool => 1 }; - event plan => { max => 3 }; - directive 'end'; - }, - "Make sure plan monkeypatching does not effect done_testing" -); - -ok($ok, "Did not die"); diff --git a/cpan/Test-Simple/t/Behavior/Munge.t b/cpan/Test-Simple/t/Behavior/Munge.t deleted file mode 100644 index be9aa98d5c..0000000000 --- a/cpan/Test-Simple/t/Behavior/Munge.t +++ /dev/null @@ -1,30 +0,0 @@ -use strict; -use warnings; -use Test::Stream; -use Test::More; -use Test::Stream::Tester; - -events_are( - intercept { - my $id = 0; - Test::Stream->shared->munge(sub { - my ($stream, $e) = @_; - return unless $e->isa('Test::Stream::Event::Ok'); - return if defined $e->name; - $e->set_name( 'flubber: ' . $id++ ); - }); - - ok( 1, "Keep the name" ); - ok( 1 ); - ok( 1, "Already named" ); - ok( 1 ); - }, - check { - event ok => { bool => 1, name => "Keep the name" }; - event ok => { bool => 1, name => "flubber: 0" }; - event ok => { bool => 1, name => "Already named" }; - event ok => { bool => 1, name => "flubber: 1" }; - } -); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/NotTB15.t b/cpan/Test-Simple/t/Behavior/NotTB15.t deleted file mode 100644 index a70992599d..0000000000 --- a/cpan/Test-Simple/t/Behavior/NotTB15.t +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/perl -use strict; -use warnings; - -use Test::More; -use Test::Builder; - -# This is just a list of method Test::Builder current does not have that Test::Builder 1.5 does. -my @TB15_METHODS = qw{ - _file_and_line _join_message _make_default _my_exit _reset_todo_state - _result_to_hash _results _todo_state formatter history in_test - no_change_exit_code post_event post_result set_formatter set_plan test_end - test_exit_code test_start test_state -}; - -for my $method (qw/foo bar baz/) { - my $success = !eval { Test::Builder->$method; 1 }; my $line = __LINE__; - my $error = $@; - ok($success, "Threw an exception ($method)"); - is( - $error, - qq{Can't locate object method "$method" via package "Test::Builder" at } . __FILE__ . " line $line.\n", - "Did not auto-create random sub ($method)" - ); -} - -my $file = __FILE__; -for my $method (@TB15_METHODS) { - my $success = !eval { Test::Builder->$method; 1 }; my $line = __LINE__; - my $error = $@; - - ok($success, "Threw an exception ($method)"); - - is($error, <<" EOT", "Got expected error ($method)"); -Can't locate object method "$method" via package "Test::Builder" at $file line $line. - - ************************************************************************* - '$method' is a Test::Builder 1.5 method. Test::Builder 1.5 is a dead branch. - You need to update your code so that it no longer treats Test::Builders - over a specific version number as anything special. - - See: http://blogs.perl.org/users/chad_exodist_granum/2014/03/testmore---new-maintainer-also-stop-version-checking.html - ************************************************************************* - EOT -} - -done_testing; - diff --git a/cpan/Test-Simple/t/Behavior/Tester2_subtest.t b/cpan/Test-Simple/t/Behavior/Tester2_subtest.t deleted file mode 100644 index 6101fbb92a..0000000000 --- a/cpan/Test-Simple/t/Behavior/Tester2_subtest.t +++ /dev/null @@ -1,69 +0,0 @@ -use strict; -use warnings; -use utf8; - -use Test::Stream; -use Test::More; -use Test::Stream::Tester; - -my $events = intercept { - ok(0, "test failure" ); - ok(1, "test success" ); - - subtest 'subtest' => sub { - ok(0, "subtest failure" ); - ok(1, "subtest success" ); - - subtest 'subtest_deeper' => sub { - ok(1, "deeper subtest success" ); - }; - }; - - ok(0, "another test failure" ); - ok(1, "another test success" ); -}; - -events_are( - $events, - - check { - event ok => {bool => 0, diag => qr/Fail/}; - event ok => {bool => 1}; - - event note => {message => 'Subtest: subtest'}; - event subtest => { - name => 'subtest', - bool => 0, - diag => qr/Failed test 'subtest'/, - - events => check { - event ok => {bool => 0}; - event ok => {bool => 1}; - - event note => {message => 'Subtest: subtest_deeper'}; - event subtest => { - bool => 1, - name => 'subtest_deeper', - events => check { - event ok => { bool => 1 }; - }, - }; - - event plan => { max => 3 }; - event finish => { tests_run => 3, tests_failed => 1 }; - event diag => { message => qr/Looks like you failed 1 test of 3/ }; - - dir end => 'End of subtests events'; - }, - }; - - event ok => {bool => 0}; - event ok => {bool => 1}; - - dir end => "subtest events as expected"; - }, - - "Subtest events" -); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/cmp_ok_undef.t b/cpan/Test-Simple/t/Behavior/cmp_ok_undef.t deleted file mode 100644 index 1e317c55d1..0000000000 --- a/cpan/Test-Simple/t/Behavior/cmp_ok_undef.t +++ /dev/null @@ -1,19 +0,0 @@ -use Test::More; -use strict; -use warnings; - -use Test::Stream::Tester; - -my @warnings; -local $SIG{__WARN__} = sub { push @warnings => @_ }; -my @events = intercept { cmp_ok( undef, '==', 6 ) }; - -is(@warnings, 1, "1 warning"); - -like( - $warnings[0], - qr/Use of uninitialized value .* at \(eval in cmp_ok\)/, - "Got the expected warning" -); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/cmp_ok_xor.t b/cpan/Test-Simple/t/Behavior/cmp_ok_xor.t deleted file mode 100644 index 292f7168be..0000000000 --- a/cpan/Test-Simple/t/Behavior/cmp_ok_xor.t +++ /dev/null @@ -1,13 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -my @warnings; -$SIG{__WARN__} = sub { push @warnings => @_ }; -my $ok = cmp_ok( 1, 'xor', 0, 'use xor in cmp_ok' ); -ok(!@warnings, "no warnings"); -ok($ok, "returned true"); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/encoding_test.t b/cpan/Test-Simple/t/Behavior/encoding_test.t deleted file mode 100644 index 57242e03d9..0000000000 --- a/cpan/Test-Simple/t/Behavior/encoding_test.t +++ /dev/null @@ -1,35 +0,0 @@ -use strict; -use warnings; -no utf8; - -# line 5 "encoding_tést.t" - -use Test::Stream; -use Test::More; -use Test::Stream::Tester; - -BEGIN { - my $norm = eval { require Unicode::Normalize; require Encode; 1 }; - plan skip_all => 'Unicode::Normalize is required for this test' unless $norm; -} - -my $filename = __FILE__; -ok(!utf8::is_utf8($filename), "filename is not in utf8 yet"); -my $utf8name = Unicode::Normalize::NFKC(Encode::decode('utf8', "$filename", Encode::FB_CROAK)); -ok( $filename ne $utf8name, "sanity check" ); - -my $scoper = sub { context()->snapshot }; - -tap_encoding 'utf8'; -my $ctx_utf8 = $scoper->(); - -tap_encoding 'legacy'; -my $ctx_legacy = $scoper->(); - -is($ctx_utf8->encoding, 'utf8', "got a utf8 context"); -is($ctx_legacy->encoding, 'legacy', "got a legacy context"); - -is($ctx_utf8->file, $utf8name, "Got utf8 name"); -is($ctx_legacy->file, $filename, "Got legacy name"); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/event_clone_args.t b/cpan/Test-Simple/t/Behavior/event_clone_args.t deleted file mode 100644 index 7d4824d550..0000000000 --- a/cpan/Test-Simple/t/Behavior/event_clone_args.t +++ /dev/null @@ -1,22 +0,0 @@ -use Test::More; -use strict; -use warnings; - -use B; -use Test::Stream::Tester qw/intercept/; - -my @events; - -my $x1 = \(my $y1); -push @events => intercept { note $x1 }; -is(B::svref_2object($x1)->REFCNT, 2, "Note does not store a ref"); - -my $x2 = \(my $y2); -push @events => intercept { diag $x2 }; -is(B::svref_2object($x2)->REFCNT, 2, "diag does not store a ref"); - -my $x3 = \(my $y3); -push @events => intercept { ok($x3, "Generating") }; -is(B::svref_2object($x3)->REFCNT, 2, "ok does not store a ref"); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/fork_new_end.t b/cpan/Test-Simple/t/Behavior/fork_new_end.t deleted file mode 100644 index 7e7c2d7c25..0000000000 --- a/cpan/Test-Simple/t/Behavior/fork_new_end.t +++ /dev/null @@ -1,30 +0,0 @@ -use strict; -use warnings; - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - -use Test::CanThread qw/AUTHOR_TESTING/; -use Test::More tests => 4; - -ok(1, "outside before"); - -my $run = sub { - ok(1, 'in thread1'); - ok(1, 'in thread2'); -}; - - -my $t = threads->create($run); - -ok(1, "outside after"); - -$t->join; - -END { - print "XXX: " . Test::Builder->new->is_passing . "\n"; -} diff --git a/cpan/Test-Simple/t/Behavior/skip_all_in_subtest.t b/cpan/Test-Simple/t/Behavior/skip_all_in_subtest.t deleted file mode 100644 index 5f8abea6a6..0000000000 --- a/cpan/Test-Simple/t/Behavior/skip_all_in_subtest.t +++ /dev/null @@ -1,31 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More; - -my @warnings; -local $SIG{__WARN__} = sub { push @warnings, $_[0] }; - -subtest my_subtest1 => sub { - my $file = __FILE__; - $file =~ s/\.t$/1.load/; - do $file; -}; - -is(scalar(@warnings), 1, "one warning"); -like( - $warnings[0], - qr/^SKIP_ALL in subtest via 'BEGIN' or 'use'/, - "the warning" -); - - -subtest my_subtest2 => sub { - my $file = __FILE__; - $file =~ s/\.t$/2.load/; - do $file; -}; - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/skip_all_in_subtest1.load b/cpan/Test-Simple/t/Behavior/skip_all_in_subtest1.load deleted file mode 100644 index 241ce14963..0000000000 --- a/cpan/Test-Simple/t/Behavior/skip_all_in_subtest1.load +++ /dev/null @@ -1,10 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Carp qw/confess/; - -use Test::More skip_all => "Cause I feel like it"; - -confess "Should not see this!"; diff --git a/cpan/Test-Simple/t/Behavior/skip_all_in_subtest2.load b/cpan/Test-Simple/t/Behavior/skip_all_in_subtest2.load deleted file mode 100644 index 6ce306a6de..0000000000 --- a/cpan/Test-Simple/t/Behavior/skip_all_in_subtest2.load +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Carp qw/confess/; - -use Test::More; - -plan skip_all => "Cause I feel like it"; - -confess "Should not see this!"; diff --git a/cpan/Test-Simple/t/Behavior/subtest_die.t b/cpan/Test-Simple/t/Behavior/subtest_die.t deleted file mode 100644 index 49f8f88d9d..0000000000 --- a/cpan/Test-Simple/t/Behavior/subtest_die.t +++ /dev/null @@ -1,35 +0,0 @@ -use strict; -use warnings; -use Test::More; - -use Test::Stream::Tester; - -my ($ok, $err); -events_are( - intercept { - $ok = eval { - subtest foo => sub { - ok(1, "Pass"); - die "Ooops"; - }; - 1; - }; - $err = $@; - }, - check { - directive seek => 1; - event subtest => { - bool => 0, - real_bool => 0, - name => 'foo', - exception => qr/^Ooops/, - }; - directive 'end'; - }, - "Subtest fails if it throws an exception" -); - -ok(!$ok, "subtest died"); -like($err, qr/^Ooops/, "Got expected exception"); - -done_testing; diff --git a/cpan/Test-Simple/t/Behavior/threads_with_taint_mode.t b/cpan/Test-Simple/t/Behavior/threads_with_taint_mode.t deleted file mode 100644 index 71a80e932b..0000000000 --- a/cpan/Test-Simple/t/Behavior/threads_with_taint_mode.t +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/perl -w -T -use strict; -use warnings; - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't'; - @INC = '../lib'; - } -} - -use Test::CanThread qw/AUTHOR_TESTING/; - -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/Behavior/todo.t b/cpan/Test-Simple/t/Behavior/todo.t deleted file mode 100644 index cb5a6e34b0..0000000000 --- a/cpan/Test-Simple/t/Behavior/todo.t +++ /dev/null @@ -1,43 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use Test::Stream::Tester; - -my $events = intercept { - local $TODO = ""; - ok(0, "Should not be in todo 1"); - - local $TODO = 0; - ok(0, "Should not be in todo 2"); - - local $TODO = undef; - ok(0, "Should not be in todo 3"); - - local $TODO = "foo"; - ok(0, "Should be in todo"); -}; - -events_are( - $events, - check { - event ok => { in_todo => 0 }; - event ok => { in_todo => 0 }; - event ok => { in_todo => 0 }; - event ok => { in_todo => 1 }; - directive 'end'; - }, - "Verify TODO state" -); - -my $i = 0; -for my $e (@$events) { - next if $e->context->in_todo; - - my @tap = $e->to_tap(++$i); - my $ok_line = $tap[0]; - chomp(my $text = $ok_line->[1]); - is($text, "not ok $i - Should not be in todo $i", "No TODO directive $i"); -} - -done_testing; 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..64be8511d8 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/create.t @@ -0,0 +1,38 @@ +#!/usr/bin/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/is_passing.t b/cpan/Test-Simple/t/Builder/is_passing.t new file mode 100644 index 0000000000..d335aada57 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/is_passing.t @@ -0,0 +1,106 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +# We're going to need to override exit() later +BEGIN { + *CORE::GLOBAL::exit = sub(;$) { + my $status = @_ ? 0 : shift; + CORE::exit $status; + }; +} + +use Test::More; +use Test::Builder; +use Test::Builder::NoOutput; + +{ + my $tb = Test::Builder::NoOutput->create; + ok $tb->is_passing, "a fresh TB object is passing"; + + $tb->ok(1); + ok $tb->is_passing, " still passing after a test"; + + $tb->ok(0); + ok !$tb->is_passing, " not passing after a failing test"; + + $tb->ok(1); + ok !$tb->is_passing, " a passing test doesn't resurrect it"; + + $tb->done_testing(3); + ok !$tb->is_passing, " a successful plan doesn't help either"; +} + + +# See if is_passing() notices a plan overrun +{ + my $tb = Test::Builder::NoOutput->create; + $tb->plan( tests => 1 ); + $tb->ok(1); + ok $tb->is_passing, "Passing with a plan"; + + $tb->ok(1); + ok !$tb->is_passing, " passing test, but it overran the plan"; +} + + +# is_passing() vs no_plan +{ + my $tb = Test::Builder::NoOutput->create; + $tb->plan( "no_plan" ); + ok $tb->is_passing, "Passing with no_plan"; + + $tb->ok(1); + ok $tb->is_passing, " still passing after a test"; + + $tb->ok(1); + ok $tb->is_passing, " and another test"; + + $tb->_ending; + ok $tb->is_passing, " and after the ending"; +} + + +# is_passing() vs skip_all +{ + my $tb = Test::Builder::NoOutput->create; + + { + no warnings 'redefine'; + local *CORE::GLOBAL::exit = sub { + return 1; + }; + $tb->plan( "skip_all" ); + } + ok $tb->is_passing, "Passing with skip_all"; +} + + +# is_passing() vs done_testing(#) +{ + my $tb = Test::Builder::NoOutput->create; + $tb->ok(1); + $tb->done_testing(2); + ok !$tb->is_passing, "All tests passed but done_testing() does not match"; +} + + +# is_passing() with no tests run vs done_testing() +{ + my $tb = Test::Builder::NoOutput->create; + $tb->done_testing(); + ok !$tb->is_passing, "No tests run with done_testing()"; +} + + +# is_passing() with no tests run vs done_testing() +{ + my $tb = Test::Builder::NoOutput->create; + $tb->ok(1); + $tb->done_testing(); + ok $tb->is_passing, "All tests passed with done_testing()"; +} + + +done_testing(); 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..03e0cc489d --- /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 +# suppressed 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..64a0e19476 --- /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 declared 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 = ); + 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 = ; + 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, <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); + +$tb->done_testing; # make sure done_testing gets reset + +# Now reset it. +$tb->reset; + + +# Test the state of the reset builder +$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' ); + +# The reset Test::Builder will take over from here. +$Test->no_ending(1); + + +$tb->current_test($Test->current_test); +$tb->level(0); +$tb->ok(1, 'final test to make sure output was reset'); + +$tb->done_testing; diff --git a/cpan/Test-Simple/t/Builder/reset_outputs.t b/cpan/Test-Simple/t/Builder/reset_outputs.t new file mode 100644 index 0000000000..b199128ad3 --- /dev/null +++ b/cpan/Test-Simple/t/Builder/reset_outputs.t @@ -0,0 +1,35 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::Builder; +use Test::More 'no_plan'; + +{ + my $tb = Test::Builder->create(); + + # Store the original output filehandles and change them all. + my %original_outputs; + + open my $fh, ">", "dummy_file.tmp"; + END { 1 while unlink "dummy_file.tmp"; } + for my $method (qw(output failure_output todo_output)) { + $original_outputs{$method} = $tb->$method(); + $tb->$method($fh); + is $tb->$method(), $fh; + } + + $tb->reset_outputs; + + for my $method (qw(output failure_output todo_output)) { + is $tb->$method(), $original_outputs{$method}, "reset_outputs() resets $method"; + } +} 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/Legacy/BEGIN_require_ok.t b/cpan/Test-Simple/t/Legacy/BEGIN_require_ok.t deleted file mode 100644 index 733d0bb861..0000000000 --- a/cpan/Test-Simple/t/Legacy/BEGIN_require_ok.t +++ /dev/null @@ -1,27 +0,0 @@ -#!/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/Legacy/BEGIN_use_ok.t b/cpan/Test-Simple/t/Legacy/BEGIN_use_ok.t deleted file mode 100644 index 476badf7a2..0000000000 --- a/cpan/Test-Simple/t/Legacy/BEGIN_use_ok.t +++ /dev/null @@ -1,26 +0,0 @@ -#!/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/Legacy/Builder/Builder.t b/cpan/Test-Simple/t/Legacy/Builder/Builder.t deleted file mode 100644 index a5bfd155a6..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/Builder.t +++ /dev/null @@ -1,30 +0,0 @@ -#!/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/Legacy/Builder/carp.t b/cpan/Test-Simple/t/Legacy/Builder/carp.t deleted file mode 100644 index b363438cbc..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/carp.t +++ /dev/null @@ -1,34 +0,0 @@ -#!/usr/bin/perl -use strict; -use warnings; - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - - -use Test::More tests => 3; -use Test::Builder; -use Test::Stream::Context qw/context/; - -sub foo { my $ctx = context(); Test::Builder->new->croak("foo") } -sub bar { my $ctx = context(); Test::Builder->new->carp("bar") } - -eval { foo() }; -is $@, sprintf "foo at %s line %s.\n", $0, __LINE__ - 1; - -eval { Test::Builder->new->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/Legacy/Builder/create.t b/cpan/Test-Simple/t/Legacy/Builder/create.t deleted file mode 100644 index 64be8511d8..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/create.t +++ /dev/null @@ -1,38 +0,0 @@ -#!/usr/bin/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/Legacy/Builder/current_test.t b/cpan/Test-Simple/t/Legacy/Builder/current_test.t deleted file mode 100644 index edd201c0e9..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/current_test.t +++ /dev/null @@ -1,11 +0,0 @@ -#!/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/Legacy/Builder/current_test_without_plan.t b/cpan/Test-Simple/t/Legacy/Builder/current_test_without_plan.t deleted file mode 100644 index 31f9589977..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/current_test_without_plan.t +++ /dev/null @@ -1,16 +0,0 @@ -#!/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/Legacy/Builder/details.t b/cpan/Test-Simple/t/Legacy/Builder/details.t deleted file mode 100644 index 05d4828b4d..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/details.t +++ /dev/null @@ -1,104 +0,0 @@ -#!/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/Legacy/Builder/done_testing.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing.t deleted file mode 100644 index 14a8f918b0..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing.t +++ /dev/null @@ -1,12 +0,0 @@ -#!/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/Legacy/Builder/done_testing_double.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t deleted file mode 100644 index 3a0bae247b..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t +++ /dev/null @@ -1,47 +0,0 @@ -#!/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/Legacy/Builder/done_testing_plan_mismatch.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t deleted file mode 100644 index 8208635359..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t +++ /dev/null @@ -1,45 +0,0 @@ -#!/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/Legacy/Builder/done_testing_with_no_plan.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t deleted file mode 100644 index ff5f40c197..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t +++ /dev/null @@ -1,11 +0,0 @@ -#!/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/Legacy/Builder/done_testing_with_number.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing_with_number.t deleted file mode 100644 index c21458f54e..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing_with_number.t +++ /dev/null @@ -1,12 +0,0 @@ -#!/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/Legacy/Builder/done_testing_with_plan.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t deleted file mode 100644 index 2d10322eea..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t +++ /dev/null @@ -1,11 +0,0 @@ -#!/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/Legacy/Builder/fork_with_new_stdout.t b/cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t deleted file mode 100644 index 5adb739eb2..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t +++ /dev/null @@ -1,48 +0,0 @@ -#!perl -w -use strict; -use warnings; - -use Test::CanFork; - -use IO::Pipe; -use Test::Builder; - -my $b = Test::Builder->new; -$b->reset; -$b->plan('tests' => 2); - -my $pipe = IO::Pipe->new; -if (my $pid = fork) { - $pipe->reader; - my @output = <$pipe>; - $b->like($output[0], qr/ok 1/, "ok 1 from child"); - $b->like($output[1], qr/1\.\.1/, "got 1..1 from child"); - waitpid($pid, 0); -} -else { - Test::Stream::IOSets->hard_reset; - Test::Stream->clear; - $pipe->writer; - my $pipe_fd = $pipe->fileno; - close STDOUT; - open(STDOUT, ">&$pipe_fd"); - my $b = Test::Builder->create(shared_stream => 1); - $b->reset; - $b->no_plan; - $b->ok(1); - - exit 0; -} - -=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/Legacy/Builder/has_plan.t b/cpan/Test-Simple/t/Legacy/Builder/has_plan.t deleted file mode 100644 index d0be86a97a..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/has_plan.t +++ /dev/null @@ -1,23 +0,0 @@ -#!/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/Legacy/Builder/has_plan2.t b/cpan/Test-Simple/t/Legacy/Builder/has_plan2.t deleted file mode 100644 index e13ea4af94..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/has_plan2.t +++ /dev/null @@ -1,22 +0,0 @@ -#!/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/Legacy/Builder/is_fh.t b/cpan/Test-Simple/t/Legacy/Builder/is_fh.t deleted file mode 100644 index f7a5f1a80d..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/is_fh.t +++ /dev/null @@ -1,48 +0,0 @@ -#!/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/Legacy/Builder/is_passing.t b/cpan/Test-Simple/t/Legacy/Builder/is_passing.t deleted file mode 100644 index d335aada57..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/is_passing.t +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use lib 't/lib'; - -# We're going to need to override exit() later -BEGIN { - *CORE::GLOBAL::exit = sub(;$) { - my $status = @_ ? 0 : shift; - CORE::exit $status; - }; -} - -use Test::More; -use Test::Builder; -use Test::Builder::NoOutput; - -{ - my $tb = Test::Builder::NoOutput->create; - ok $tb->is_passing, "a fresh TB object is passing"; - - $tb->ok(1); - ok $tb->is_passing, " still passing after a test"; - - $tb->ok(0); - ok !$tb->is_passing, " not passing after a failing test"; - - $tb->ok(1); - ok !$tb->is_passing, " a passing test doesn't resurrect it"; - - $tb->done_testing(3); - ok !$tb->is_passing, " a successful plan doesn't help either"; -} - - -# See if is_passing() notices a plan overrun -{ - my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 1 ); - $tb->ok(1); - ok $tb->is_passing, "Passing with a plan"; - - $tb->ok(1); - ok !$tb->is_passing, " passing test, but it overran the plan"; -} - - -# is_passing() vs no_plan -{ - my $tb = Test::Builder::NoOutput->create; - $tb->plan( "no_plan" ); - ok $tb->is_passing, "Passing with no_plan"; - - $tb->ok(1); - ok $tb->is_passing, " still passing after a test"; - - $tb->ok(1); - ok $tb->is_passing, " and another test"; - - $tb->_ending; - ok $tb->is_passing, " and after the ending"; -} - - -# is_passing() vs skip_all -{ - my $tb = Test::Builder::NoOutput->create; - - { - no warnings 'redefine'; - local *CORE::GLOBAL::exit = sub { - return 1; - }; - $tb->plan( "skip_all" ); - } - ok $tb->is_passing, "Passing with skip_all"; -} - - -# is_passing() vs done_testing(#) -{ - my $tb = Test::Builder::NoOutput->create; - $tb->ok(1); - $tb->done_testing(2); - ok !$tb->is_passing, "All tests passed but done_testing() does not match"; -} - - -# is_passing() with no tests run vs done_testing() -{ - my $tb = Test::Builder::NoOutput->create; - $tb->done_testing(); - ok !$tb->is_passing, "No tests run with done_testing()"; -} - - -# is_passing() with no tests run vs done_testing() -{ - my $tb = Test::Builder::NoOutput->create; - $tb->ok(1); - $tb->done_testing(); - ok $tb->is_passing, "All tests passed with done_testing()"; -} - - -done_testing(); diff --git a/cpan/Test-Simple/t/Legacy/Builder/maybe_regex.t b/cpan/Test-Simple/t/Legacy/Builder/maybe_regex.t deleted file mode 100644 index fd8b8d06ed..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/maybe_regex.t +++ /dev/null @@ -1,60 +0,0 @@ -#!/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/Legacy/Builder/no_diag.t b/cpan/Test-Simple/t/Legacy/Builder/no_diag.t deleted file mode 100644 index 6fa538a82e..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/no_diag.t +++ /dev/null @@ -1,8 +0,0 @@ -#!/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/Legacy/Builder/no_ending.t b/cpan/Test-Simple/t/Legacy/Builder/no_ending.t deleted file mode 100644 index 03e0cc489d..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/no_ending.t +++ /dev/null @@ -1,21 +0,0 @@ -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 -# suppressed the ending diagnostics. -pass; -print "ok 2\n"; -print "ok 3\n"; diff --git a/cpan/Test-Simple/t/Legacy/Builder/no_header.t b/cpan/Test-Simple/t/Legacy/Builder/no_header.t deleted file mode 100644 index 93e6bec34c..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/no_header.t +++ /dev/null @@ -1,21 +0,0 @@ -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/Legacy/Builder/no_plan_at_all.t b/cpan/Test-Simple/t/Legacy/Builder/no_plan_at_all.t deleted file mode 100644 index 64a0e19476..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/no_plan_at_all.t +++ /dev/null @@ -1,36 +0,0 @@ -#!/usr/bin/perl -w - -# Test what happens when no plan is declared 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/Legacy/Builder/ok_obj.t b/cpan/Test-Simple/t/Legacy/Builder/ok_obj.t deleted file mode 100644 index 8678dbff8d..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/ok_obj.t +++ /dev/null @@ -1,29 +0,0 @@ -#!/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/Legacy/Builder/output.t b/cpan/Test-Simple/t/Legacy/Builder/output.t deleted file mode 100644 index 77e0e0bbb3..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/output.t +++ /dev/null @@ -1,113 +0,0 @@ -#!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 = ); - 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 = ; - 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, <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); - -$tb->done_testing; # make sure done_testing gets reset - -# Now reset it. -$tb->reset; - - -# Test the state of the reset builder -$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->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' ); - -# The reset Test::Builder will take over from here. -$Test->no_ending(1); - -$tb->current_test($Test->current_test); -$tb->level(0); -$tb->ok(1, 'final test to make sure output was reset'); - -$tb->done_testing; diff --git a/cpan/Test-Simple/t/Legacy/Builder/reset_outputs.t b/cpan/Test-Simple/t/Legacy/Builder/reset_outputs.t deleted file mode 100644 index b199128ad3..0000000000 --- a/cpan/Test-Simple/t/Legacy/Builder/reset_outputs.t +++ /dev/null @@ -1,35 +0,0 @@ -#!perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use Test::Builder; -use Test::More 'no_plan'; - -{ - my $tb = Test::Builder->create(); - - # Store the original output filehandles and change them all. - my %original_outputs; - - open my $fh, ">", "dummy_file.tmp"; - END { 1 while unlink "dummy_file.tmp"; } - for my $method (qw(output failure_output todo_output)) { - $original_outputs{$method} = $tb->$method(); - $tb->$method($fh); - is $tb->$method(), $fh; - } - - $tb->reset_outputs; - - for my $method (qw(output failure_output todo_output)) { - is $tb->$method(), $original_outputs{$method}, "reset_outputs() resets $method"; - } -} diff --git a/cpan/Test-Simple/t/Legacy/More.t b/cpan/Test-Simple/t/Legacy/More.t deleted file mode 100644 index b4f680bb31..0000000000 --- a/cpan/Test-Simple/t/Legacy/More.t +++ /dev/null @@ -1,185 +0,0 @@ -#!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 => 54; -use Test::Builder; - -# 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] } - ); - - -# rt.cpan.org 53469 is_deeply with regexes -is_deeply( qr/a/, qr/a/, "same regex" ); - - -# These two tests must remain at the end. -is( $@, $Err, '$@ untouched' ); -cmp_ok( $!, '==', $Errno, '$! untouched' ); diff --git a/cpan/Test-Simple/t/Legacy/PerlIO.t b/cpan/Test-Simple/t/Legacy/PerlIO.t deleted file mode 100644 index 84ba649b37..0000000000 --- a/cpan/Test-Simple/t/Legacy/PerlIO.t +++ /dev/null @@ -1,11 +0,0 @@ -use Test::More; -require PerlIO; - -my $ok = 1; -my %counts; -for my $layer (PerlIO::get_layers(Test::Stream->shared->io_sets->{legacy}->[0])) { - my $dup = $counts{$layer}++; - ok(!$dup, "No IO layer duplication '$layer'"); -} - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/Simple/load.t b/cpan/Test-Simple/t/Legacy/Simple/load.t deleted file mode 100644 index 938569a5b8..0000000000 --- a/cpan/Test-Simple/t/Legacy/Simple/load.t +++ /dev/null @@ -1,13 +0,0 @@ -#!/usr/bin/perl - -# Because I broke "use Test::Simple", here's a test - -use strict; -use warnings; - -use Test::Simple; - -print < 4; - -use SmallTest; - -use MyTest; - -{ - my ($prem, @results) = run_tests(sub { MyTest::ok(1, "run pass") }); - - is_eq($results[0]->{name}, "run pass"); - is_num($results[0]->{ok}, 1); -} - -{ - my ($prem, @results) = run_tests(sub { MyTest::ok(0, "run fail") }); - - is_eq($results[0]->{name}, "run fail"); - is_num($results[0]->{ok}, 0); -} diff --git a/cpan/Test-Simple/t/Legacy/TestTester/check_tests.t b/cpan/Test-Simple/t/Legacy/TestTester/check_tests.t deleted file mode 100644 index 96b8470329..0000000000 --- a/cpan/Test-Simple/t/Legacy/TestTester/check_tests.t +++ /dev/null @@ -1,116 +0,0 @@ -use strict; - -use Test::Tester; - -use Data::Dumper qw(Dumper); - -my $test = Test::Builder->new; -$test->plan(tests => 105); - -my $cap; - -$cap = $test; - -my @tests = ( - [ - 'pass', - '$cap->ok(1, "pass");', - { - name => "pass", - ok => 1, - actual_ok => 1, - reason => "", - type => "", - diag => "", - depth => 0, - }, - ], - [ - 'pass diag', - '$cap->ok(1, "pass diag"); - $cap->diag("pass diag1"); - $cap->diag("pass diag2");', - { - name => "pass diag", - ok => 1, - actual_ok => 1, - reason => "", - type => "", - diag => "pass diag1\npass diag2\n", - depth => 0, - }, - ], - [ - 'pass diag no \\n', - '$cap->ok(1, "pass diag"); - $cap->diag("pass diag1"); - $cap->diag("pass diag2");', - { - name => "pass diag", - ok => 1, - actual_ok => 1, - reason => "", - type => "", - diag => "pass diag1\npass diag2", - depth => 0, - }, - ], - [ - 'fail', - '$cap->ok(0, "fail"); - $cap->diag("fail diag");', - { - name => "fail", - ok => 0, - actual_ok => 0, - reason => "", - type => "", - diag => "fail diag\n", - depth => 0, - }, - ], - [ - 'skip', - '$cap->skip("just because");', - { - name => "", - ok => 1, - actual_ok => 1, - reason => "just because", - type => "skip", - diag => "", - depth => 0, - }, - ], - [ - 'todo_skip', - '$cap->todo_skip("why not");', - { - name => "", - ok => 1, - actual_ok => 0, - reason => "why not", - type => "todo_skip", - diag => "", - depth => 0, - }, - ], -); - -my $big_code = ""; -my @big_expect; - -foreach my $test (@tests) { - my ($name, $code, $expect) = @$test; - - $big_code .= "$code\n"; - push(@big_expect, $expect); - - my $test_sub = eval "sub {$code}"; - - check_test($test_sub, $expect, $name); -} - -my $big_test_sub = eval "sub {$big_code}"; - -check_tests($big_test_sub, \@big_expect, "run all"); diff --git a/cpan/Test-Simple/t/Legacy/TestTester/depth.t b/cpan/Test-Simple/t/Legacy/TestTester/depth.t deleted file mode 100644 index 53ba7e0779..0000000000 --- a/cpan/Test-Simple/t/Legacy/TestTester/depth.t +++ /dev/null @@ -1,39 +0,0 @@ -use strict; -use warnings; - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use Test::Tester; - -use MyTest; - -my $test = Test::Builder->new; -$test->plan(tests => 2); - -sub deeper -{ - MyTest::ok(1); -} - -{ - - my @results = run_tests( - sub { - MyTest::ok(1); - deeper(); - } - ); - - local $Test::Builder::Level = 0; - $test->is_num($results[1]->{depth}, 1, "depth 1"); - $test->is_num($results[2]->{depth}, 2, "deeper"); -} - diff --git a/cpan/Test-Simple/t/Legacy/TestTester/is_bug.t b/cpan/Test-Simple/t/Legacy/TestTester/is_bug.t deleted file mode 100644 index 64642fca2a..0000000000 --- a/cpan/Test-Simple/t/Legacy/TestTester/is_bug.t +++ /dev/null @@ -1,31 +0,0 @@ -use strict; -use warnings; -use Test::Tester; -use Test::More; - -check_test( - sub { is "Foo", "Foo" }, - {ok => 1}, -); - -check_test( - sub { is "Bar", "Bar" }, - {ok => 1}, -); - -check_test( - sub { is "Baz", "Quux" }, - {ok => 0}, -); - -check_test( - sub { like "Baz", qr/uhg/ }, - {ok => 0}, -); - -check_test( - sub { like "Baz", qr/a/ }, - {ok => 1}, -); - -done_testing(); diff --git a/cpan/Test-Simple/t/Legacy/TestTester/run_test.t b/cpan/Test-Simple/t/Legacy/TestTester/run_test.t deleted file mode 100644 index 6b1464c358..0000000000 --- a/cpan/Test-Simple/t/Legacy/TestTester/run_test.t +++ /dev/null @@ -1,145 +0,0 @@ -use strict; - -use Test::Tester; - -use Data::Dumper qw(Dumper); - -my $test = Test::Builder->new; -$test->plan(tests => 54); - -my $cap; - -{ - $cap = $test; - my ($prem, @results) = run_tests( - sub {$cap->ok(1, "run pass")} - ); - - local $Test::Builder::Level = 0; - - $test->is_eq($prem, "", "run pass no prem"); - $test->is_num(scalar (@results), 1, "run pass result count"); - - my $res = $results[0]; - - $test->is_eq($res->{name}, "run pass", "run pass name"); - $test->is_eq($res->{ok}, 1, "run pass ok"); - $test->is_eq($res->{actual_ok}, 1, "run pass actual_ok"); - $test->is_eq($res->{reason}, "", "run pass reason"); - $test->is_eq($res->{type}, "", "run pass type"); - $test->is_eq($res->{diag}, "", "run pass diag"); - $test->is_num($res->{depth}, 0, "run pass depth"); -} - -{ - my ($prem, @results) = run_tests( - sub {$cap->ok(0, "run fail")} - ); - - local $Test::Builder::Level = 0; - - $test->is_eq($prem, "", "run fail no prem"); - $test->is_num(scalar (@results), 1, "run fail result count"); - - my $res = $results[0]; - - $test->is_eq($res->{name}, "run fail", "run fail name"); - $test->is_eq($res->{actual_ok}, 0, "run fail actual_ok"); - $test->is_eq($res->{ok}, 0, "run fail ok"); - $test->is_eq($res->{reason}, "", "run fail reason"); - $test->is_eq($res->{type}, "", "run fail type"); - $test->is_eq($res->{diag}, "", "run fail diag"); - $test->is_num($res->{depth}, 0, "run fail depth"); -} - -{ - my ($prem, @results) = run_tests( - sub {$cap->skip("just because")} - ); - - local $Test::Builder::Level = 0; - - $test->is_eq($prem, "", "skip no prem"); - $test->is_num(scalar (@results), 1, "skip result count"); - - my $res = $results[0]; - - $test->is_eq($res->{name}, "", "skip name"); - $test->is_eq($res->{actual_ok}, 1, "skip actual_ok"); - $test->is_eq($res->{ok}, 1, "skip ok"); - $test->is_eq($res->{reason}, "just because", "skip reason"); - $test->is_eq($res->{type}, "skip", "skip type"); - $test->is_eq($res->{diag}, "", "skip diag"); - $test->is_num($res->{depth}, 0, "skip depth"); -} - -{ - my ($prem, @results) = run_tests( - sub {$cap->todo_skip("just because")} - ); - - local $Test::Builder::Level = 0; - - $test->is_eq($prem, "", "todo_skip no prem"); - $test->is_num(scalar (@results), 1, "todo_skip result count"); - - my $res = $results[0]; - - $test->is_eq($res->{name}, "", "todo_skip name"); - $test->is_eq($res->{actual_ok}, 0, "todo_skip actual_ok"); - $test->is_eq($res->{ok}, 1, "todo_skip ok"); - $test->is_eq($res->{reason}, "just because", "todo_skip reason"); - $test->is_eq($res->{type}, "todo_skip", "todo_skip type"); - $test->is_eq($res->{diag}, "", "todo_skip diag"); - $test->is_num($res->{depth}, 0, "todo_skip depth"); -} - -{ - my ($prem, @results) = run_tests( - sub {$cap->diag("run diag")} - ); - - local $Test::Builder::Level = 0; - - $test->is_eq($prem, "run diag\n", "run diag prem"); - $test->is_num(scalar (@results), 0, "run diag result count"); -} - -{ - my ($prem, @results) = run_tests( - sub { - $cap->ok(1, "multi pass"); - $cap->diag("multi pass diag1"); - $cap->diag("multi pass diag2"); - $cap->ok(0, "multi fail"); - $cap->diag("multi fail diag"); - } - ); - - local $Test::Builder::Level = 0; - - $test->is_eq($prem, "", "run multi no prem"); - $test->is_num(scalar (@results), 2, "run multi result count"); - - my $res_pass = $results[0]; - - $test->is_eq($res_pass->{name}, "multi pass", "run multi pass name"); - $test->is_eq($res_pass->{actual_ok}, 1, "run multi pass actual_ok"); - $test->is_eq($res_pass->{ok}, 1, "run multi pass ok"); - $test->is_eq($res_pass->{reason}, "", "run multi pass reason"); - $test->is_eq($res_pass->{type}, "", "run multi pass type"); - $test->is_eq($res_pass->{diag}, "multi pass diag1\nmulti pass diag2\n", - "run multi pass diag"); - $test->is_num($res_pass->{depth}, 0, "run multi pass depth"); - - my $res_fail = $results[1]; - - $test->is_eq($res_fail->{name}, "multi fail", "run multi fail name"); - $test->is_eq($res_pass->{actual_ok}, 1, "run multi fail actual_ok"); - $test->is_eq($res_fail->{ok}, 0, "run multi fail ok"); - $test->is_eq($res_pass->{reason}, "", "run multi fail reason"); - $test->is_eq($res_pass->{type}, "", "run multi fail type"); - $test->is_eq($res_fail->{diag}, "multi fail diag\n", "run multi fail diag"); - $test->is_num($res_pass->{depth}, 0, "run multi fail depth"); -} - diff --git a/cpan/Test-Simple/t/Legacy/Tester/tbt_01basic.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_01basic.t deleted file mode 100644 index 1b4b556d3f..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_01basic.t +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/perl - -use Test::Builder::Tester tests => 10; -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(qr/ok 1 - tested\n/); -ok(1,"tested"); -test_test("regexp matching"); - -test_out("not ok 1 - should fail"); -test_err("# Failed test ($0 at line 32)"); -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_out("# Failed (TODO) test ($0 at line 56)"); -TODO: { - local $TODO = "Something"; - fail("name"); -} -test_test("testing failing with todo"); - diff --git a/cpan/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t deleted file mode 100644 index c7826cdf1d..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t +++ /dev/null @@ -1,58 +0,0 @@ -#!/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/Legacy/Tester/tbt_03die.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_03die.t deleted file mode 100644 index b9dba801eb..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_03die.t +++ /dev/null @@ -1,12 +0,0 @@ -#!/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/Legacy/Tester/tbt_04line_num.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_04line_num.t deleted file mode 100644 index 9e8365acbf..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_04line_num.t +++ /dev/null @@ -1,8 +0,0 @@ -#!/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/Legacy/Tester/tbt_05faildiag.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t deleted file mode 100644 index 59ad721240..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t +++ /dev/null @@ -1,44 +0,0 @@ -#!/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/Legacy/Tester/tbt_06errormess.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_06errormess.t deleted file mode 100644 index f68cba4e42..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_06errormess.t +++ /dev/null @@ -1,120 +0,0 @@ -#!/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(); - - # remember 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/Legacy/Tester/tbt_07args.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_07args.t deleted file mode 100644 index 0e322128dc..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_07args.t +++ /dev/null @@ -1,215 +0,0 @@ -#!/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(); - - # remember 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/Legacy/Tester/tbt_08subtest.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t deleted file mode 100644 index 6ec508f247..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/env perl - -use strict; -use warnings; - -use Test::Builder::Tester tests => 1; -use Test::More; - -subtest 'foo' => sub { - plan tests => 1; - - test_out("not ok 1 - foo"); - test_fail(+1); - fail("foo"); - test_test("fail works"); -}; diff --git a/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t deleted file mode 100644 index a0c8b8e2e5..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::Builder::Tester tests => 3; -use Test::More; -use File::Basename qw(dirname); -use File::Spec qw(); - -my $file = File::Spec->join(dirname(__FILE__), 'tbt_09do_script.pl'); -my $done = do $file; -ok(defined($done), 'do succeeded') or do { - if ($@) { - diag qq( \$@ is '$@'\n); - } elsif ($!) { - diag qq( \$! is '$!'\n); - } else { - diag qq( file's last statement returned undef: $file) - } -}; diff --git a/cpan/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl b/cpan/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl deleted file mode 100644 index 590a03b085..0000000000 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl +++ /dev/null @@ -1,13 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -isnt($0, __FILE__, 'code is not executing directly'); - -test_out("not ok 1 - one"); -test_fail(+1); -ok(0,"one"); -test_test('test_fail caught fail message inside a do'); - -1; diff --git a/cpan/Test-Simple/t/Legacy/bad_plan.t b/cpan/Test-Simple/t/Legacy/bad_plan.t deleted file mode 100644 index 80e0e65bca..0000000000 --- a/cpan/Test-Simple/t/Legacy/bad_plan.t +++ /dev/null @@ -1,23 +0,0 @@ -#!/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/Legacy/bail_out.t b/cpan/Test-Simple/t/Legacy/bail_out.t deleted file mode 100644 index 5cdc1f9969..0000000000 --- a/cpan/Test-Simple/t/Legacy/bail_out.t +++ /dev/null @@ -1,43 +0,0 @@ -#!/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/Legacy/buffer.t b/cpan/Test-Simple/t/Legacy/buffer.t deleted file mode 100644 index 6039e4a6f7..0000000000 --- a/cpan/Test-Simple/t/Legacy/buffer.t +++ /dev/null @@ -1,22 +0,0 @@ -#!/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/Legacy/c_flag.t b/cpan/Test-Simple/t/Legacy/c_flag.t deleted file mode 100644 index a33963415e..0000000000 --- a/cpan/Test-Simple/t/Legacy/c_flag.t +++ /dev/null @@ -1,21 +0,0 @@ -#!/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/Legacy/circular_data.t b/cpan/Test-Simple/t/Legacy/circular_data.t deleted file mode 100644 index 15eb6d406f..0000000000 --- a/cpan/Test-Simple/t/Legacy/circular_data.t +++ /dev/null @@ -1,71 +0,0 @@ -#!/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/Legacy/cmp_ok.t b/cpan/Test-Simple/t/Legacy/cmp_ok.t deleted file mode 100644 index 07ed1a9f0b..0000000000 --- a/cpan/Test-Simple/t/Legacy/cmp_ok.t +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use warnings; - -use lib 't/lib'; - -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, $error) = @_; - - my %expect; - if( $error ) { - $expect{ok} = 0; - $expect{error} = $error; - } - else { - $expect{ok} = eval "\$left $cmp \$right"; - $expect{error} = $@; - $expect{error} =~ s/ at .*\n?//; - } - - local $Test::Builder::Level = $Test::Builder::Level + 1; - - my $ok; - eval { $ok = cmp_ok($left, $cmp, $right, "cmp_ok"); }; - - $TB->is_num(!!$ok, !!$expect{ok}, " right return"); - - my $diag = $err->read; - - if ($@) { - $diag = $@; - $diag =~ s/ at .*\n?//; - } - - 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], - - [1, "=", 0, "= is not a valid comparison operator in cmp_ok()"], - [1, "+=", 0, "+= is not a valid comparison operator in cmp_ok()"], -); - -plan tests => scalar @Tests; -$TB->plan(tests => @Tests * 2); - -for my $test (@Tests) { - try_cmp_ok(@$test); -} diff --git a/cpan/Test-Simple/t/Legacy/dependents.t b/cpan/Test-Simple/t/Legacy/dependents.t deleted file mode 100644 index 90e8938ebe..0000000000 --- a/cpan/Test-Simple/t/Legacy/dependents.t +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/perl - -# Test important dependant modules so we don't accidentally half of CPAN. - -use strict; -use warnings; - -use Test::More; - -BEGIN { - plan skip_all => "Dependents only tested when releasing" unless $ENV{PERL_RELEASING}; -} - -require File::Spec; -use CPAN; - -CPAN::HandleConfig->load; -$CPAN::Config->{test_report} = 0; - -# Module which depend on Test::More to test -my @Modules = qw( - Test::Most - Test::Warn - Test::Exception - Test::Class - Test::Deep - Test::Differences - Test::NoWarnings -); - -# Modules which are known to be broken -my %Broken = map { $_ => 1 } qw( -); - -TODO: for my $name (@ARGV ? @ARGV : @Modules) { - local $TODO = "$name known to be broken" if $Broken{$name}; - - local $ENV{PERL5LIB} = "$ENV{PERL5LIB}:" . File::Spec->rel2abs("blib/lib"); - my $module = CPAN::Shell->expand("Module", $name); - $module->test; - ok( !$module->distribution->{make_test}->failed, $name ); -} - -done_testing(); diff --git a/cpan/Test-Simple/t/Legacy/diag.t b/cpan/Test-Simple/t/Legacy/diag.t deleted file mode 100644 index f5cb437d54..0000000000 --- a/cpan/Test-Simple/t/Legacy/diag.t +++ /dev/null @@ -1,81 +0,0 @@ -#!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/Legacy/died.t b/cpan/Test-Simple/t/Legacy/died.t deleted file mode 100644 index b4ee2fbbff..0000000000 --- a/cpan/Test-Simple/t/Legacy/died.t +++ /dev/null @@ -1,45 +0,0 @@ -#!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, <is_eq($err->read, <is_eq($?, 250, "exit code"); - - exit grep { !$_ } $TB->summary; -} diff --git a/cpan/Test-Simple/t/Legacy/dont_overwrite_die_handler.t b/cpan/Test-Simple/t/Legacy/dont_overwrite_die_handler.t deleted file mode 100644 index 51f4d08d4e..0000000000 --- a/cpan/Test-Simple/t/Legacy/dont_overwrite_die_handler.t +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/perl -w -use Config; # To prevent conflict with some strawberry-portable versions - -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; - -$handler_called = 0; -ok !eval { die }; -is $handler_called, 1, 'existing DIE handler not overridden'; diff --git a/cpan/Test-Simple/t/Legacy/eq_set.t b/cpan/Test-Simple/t/Legacy/eq_set.t deleted file mode 100644 index 202f3d3665..0000000000 --- a/cpan/Test-Simple/t/Legacy/eq_set.t +++ /dev/null @@ -1,34 +0,0 @@ -#!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/Legacy/exit.t b/cpan/Test-Simple/t/Legacy/exit.t deleted file mode 100644 index 69b8e1c08c..0000000000 --- a/cpan/Test-Simple/t/Legacy/exit.t +++ /dev/null @@ -1,107 +0,0 @@ -#!/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); - -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, - 'one_fail_without_plan.plx' => 1, - 'missing_done_testing.plx' => 254, - ); - -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/Legacy/explain.t b/cpan/Test-Simple/t/Legacy/explain.t deleted file mode 100644 index cf2f550e95..0000000000 --- a/cpan/Test-Simple/t/Legacy/explain.t +++ /dev/null @@ -1,27 +0,0 @@ -#!/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/Legacy/extra.t b/cpan/Test-Simple/t/Legacy/extra.t deleted file mode 100644 index 28febc3600..0000000000 --- a/cpan/Test-Simple/t/Legacy/extra.t +++ /dev/null @@ -1,63 +0,0 @@ -#!perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; - -use Test::Builder; -use Test::Builder::NoOutput; -use Test::More; - -my $TB = Test::Builder->new; -my $test = Test::Builder::NoOutput->create; -$test->plan( tests => 3 ); - -local $ENV{HARNESS_ACTIVE} = 0; - -$test->ok(1, 'Foo'); -$TB->is_eq($test->read(), <ok(0, 'Bar'); -$TB->is_eq($test->read(), <ok(1, 'Yar'); -$test->ok(1, 'Car'); -$TB->is_eq($test->read(), <ok(0, 'Sar'); -$TB->is_eq($test->read(), < 1; - $test->_ending(); - $TB->is_eq($test->read(), <<' END'); -# Looks like you planned 3 tests but ran 5. -# Looks like you failed 2 tests of 5 run. - END -} - -$TB->done_testing(5); diff --git a/cpan/Test-Simple/t/Legacy/extra_one.t b/cpan/Test-Simple/t/Legacy/extra_one.t deleted file mode 100644 index d77404e15d..0000000000 --- a/cpan/Test-Simple/t/Legacy/extra_one.t +++ /dev/null @@ -1,52 +0,0 @@ -#!/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, <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, <like($err->read, qr/^$err_re$/, 'failing errors'); -} - -{ - # line 62 - like("foo", "not a regex"); - $TB->is_eq($out->read, <is_eq($err->read, <new->no_ending(1); diff --git a/cpan/Test-Simple/t/Legacy/fail-more.t b/cpan/Test-Simple/t/Legacy/fail-more.t deleted file mode 100644 index aab2d83031..0000000000 --- a/cpan/Test-Simple/t/Legacy/fail-more.t +++ /dev/null @@ -1,526 +0,0 @@ -#!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 => 80); - -sub like ($$;$) { - my $c = Test::Stream::Context::context(); - $TB->like(@_); -} - -sub is ($$;$) { - my $c = Test::Stream::Context::context(); - $TB->is_eq(@_); -} - -sub main::out_ok ($$) { - my $c = Test::Stream::Context::context(); - $TB->is_eq( $out->read, shift ); - $TB->is_eq( $err->read, shift ); -} - -sub main::out_like ($$) { - my $c = Test::Stream::Context::context(); - my($output, $failure) = @_; - - $TB->like( $out->read, qr/$output/ ); - $TB->like( $err->read, qr/$failure/ ); -} - - -package main; - -require Test::More; -our $TODO; -my $Total = 38; -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( <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( <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( <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( <can('foo') -OUT -# Failed test 'ARRAY->can('foo')' -# at $0 line 228. -# ARRAY->can('foo') failed with an exception: -# Can't call method "can" on unblessed reference. -ERR - -#line 238 -isa_ok(bless([], "Foo"), "Wibble"); -out_ok( <new\\(\\) died -OUT -# Failed test 'undef->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( <new\\(\\) died -OUT -# Failed test 'Does::Not::Exist->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( <is_eq( $out->read, <is_eq( $err->read, <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'), <is_eq($tb->read('err'), <done_testing(2); -} diff --git a/cpan/Test-Simple/t/Legacy/fail_one.t b/cpan/Test-Simple/t/Legacy/fail_one.t deleted file mode 100644 index 61d7c081ff..0000000000 --- a/cpan/Test-Simple/t/Legacy/fail_one.t +++ /dev/null @@ -1,43 +0,0 @@ -#!/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'), <is_eq($tb->read('err'), <done_testing(2); -} diff --git a/cpan/Test-Simple/t/Legacy/filehandles.t b/cpan/Test-Simple/t/Legacy/filehandles.t deleted file mode 100644 index f7dad5d7ea..0000000000 --- a/cpan/Test-Simple/t/Legacy/filehandles.t +++ /dev/null @@ -1,18 +0,0 @@ -#!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/Legacy/fork.t b/cpan/Test-Simple/t/Legacy/fork.t deleted file mode 100644 index da7d4646ad..0000000000 --- a/cpan/Test-Simple/t/Legacy/fork.t +++ /dev/null @@ -1,22 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - -use Test::CanFork; - -use Test::More tests => 1; - -my $pid = fork; -if( $pid ) { # parent - pass("Only the parent should process the ending, not the child"); - waitpid($pid, 0); -} -else { - exit; # child -} - diff --git a/cpan/Test-Simple/t/Legacy/fork_die.t b/cpan/Test-Simple/t/Legacy/fork_die.t deleted file mode 100644 index 31fb9b64e1..0000000000 --- a/cpan/Test-Simple/t/Legacy/fork_die.t +++ /dev/null @@ -1,61 +0,0 @@ -use strict; -use warnings; - -use Test::CanFork; - -# The failure case for this test is producing 2 results, 1 pass and 1 fail, -# both with the same test number. If this test file does anything other than 1 -# (non-indented) result that passes, it has failed in one way or another. -use Test::More tests => 1; -use Test::Stream qw/context/; - -my $line; - -subtest do_it => sub { - ok(1, "Pass!"); - - my ($read, $write); - pipe($read, $write) || die "Could not open pipe"; - - my $pid = fork(); - die "Forking failed!" unless defined $pid; - - unless($pid) { - close($read); - Test::Stream::IOSets->_autoflush($write); - my $ctx = context(); - my $handles = $ctx->stream->io_sets->init_encoding('legacy'); - $handles->[0] = $write; - $handles->[1] = $write; - $handles->[2] = $write; - *STDERR = $write; - *STDOUT = $write; - - die "This process did something wrong!"; BEGIN { $line = __LINE__ }; - } - close($write); - - waitpid($pid, 0); - ok($?, "Process exited with failure"); - - my $file = __FILE__; - { - local $SIG{ALRM} = sub { die "Read Timeout\n" }; - alarm 2; - my @output = map {chomp($_); $_} <$read>; - alarm 0; - is_deeply( - \@output, - [ - "Subtest finished with a new PID ($pid vs $$) while forking support was turned off!", - 'This is almost certainly not what you wanted. Did you fork and forget to exit?', - "This process did something wrong! at $file line $line.", - ], - "Got warning and exception, nothing else" - ); - } - - ok(1, "Pass After!"); -}; - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/fork_in_subtest.t b/cpan/Test-Simple/t/Legacy/fork_in_subtest.t deleted file mode 100644 index 1a8dc16f39..0000000000 --- a/cpan/Test-Simple/t/Legacy/fork_in_subtest.t +++ /dev/null @@ -1,26 +0,0 @@ -use strict; -use warnings; - -use Test::CanFork; - -use Test::Stream 'enable_fork'; -use Test::More; -# This just goes to show how silly forking inside a subtest would actually -# be.... - -ok(1, "fine $$"); - -my $pid; -subtest my_subtest => sub { - ok(1, "inside 1 | $$"); - $pid = fork(); - ok(1, "inside 2 | $$"); -}; - -if($pid) { - waitpid($pid, 0); - - ok(1, "after $$"); - - done_testing; -} diff --git a/cpan/Test-Simple/t/Legacy/harness_active.t b/cpan/Test-Simple/t/Legacy/harness_active.t deleted file mode 100644 index bda5dae318..0000000000 --- a/cpan/Test-Simple/t/Legacy/harness_active.t +++ /dev/null @@ -1,88 +0,0 @@ -#!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( < 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/Legacy/is_deeply_dne_bug.t b/cpan/Test-Simple/t/Legacy/is_deeply_dne_bug.t deleted file mode 100644 index f4578a6460..0000000000 --- a/cpan/Test-Simple/t/Legacy/is_deeply_dne_bug.t +++ /dev/null @@ -1,47 +0,0 @@ -#!/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/Legacy/is_deeply_fail.t b/cpan/Test-Simple/t/Legacy/is_deeply_fail.t deleted file mode 100644 index b955d290f4..0000000000 --- a/cpan/Test-Simple/t/Legacy/is_deeply_fail.t +++ /dev/null @@ -1,421 +0,0 @@ -#!/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 => 100); - -# Utility testing functions. -sub ok ($;$) { - return $TB->ok(@_); -} - -sub is ($$;$) { - my($thing, $that, $name) = @_; - - my $ok = $TB->is_eq($$thing, $that, $name); - - $$thing = ''; - - return $ok; -} - -sub like ($$;$) { - my($thing, $regex, $name) = @_; - $regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s; - - my $ok = $TB->like($$thing, $regex, $name); - - $$thing = ''; - - 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, < 42 }, { this => 43 }, 'hashes with different values'); -is( $out, "not ok 3 - hashes with different values\n", - 'hashes with different values' ); -is( $err, <{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, <{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, <[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, <[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, <{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, < \$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, <{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, <[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, <[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, <[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, < 0}, {x => ''}, "{x => 0} != {x => ''}" ); - is( $out, "not ok 39 - {x => 0} != {x => ''}\n" ); - ok !is_deeply( {x => 0}, {x => undef}, "{x => 0} != {x => undef}" ); - is( $out, "not ok 40 - {x => 0} != {x => undef}\n" ); - ok !is_deeply( {x => ''}, {x => undef}, "{x => ''} != {x => undef}" ); - is( $out, "not ok 41 - {x => ''} != {x => undef}\n" ); -} diff --git a/cpan/Test-Simple/t/Legacy/is_deeply_with_threads.t b/cpan/Test-Simple/t/Legacy/is_deeply_with_threads.t deleted file mode 100644 index 50d20042fd..0000000000 --- a/cpan/Test-Simple/t/Legacy/is_deeply_with_threads.t +++ /dev/null @@ -1,53 +0,0 @@ -#!/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 Test::CanThread qw/AUTHOR_TESTING/; - -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/Legacy/missing.t b/cpan/Test-Simple/t/Legacy/missing.t deleted file mode 100644 index 3996b6de4b..0000000000 --- a/cpan/Test-Simple/t/Legacy/missing.t +++ /dev/null @@ -1,56 +0,0 @@ -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, < 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(); -}; -my $error = $@; -$error =~ s/\.?\n.*$//gsm; -is $error, sprintf "new_ok() must be given at least a class at %s line %d", $0, __LINE__ - 4; diff --git a/cpan/Test-Simple/t/Legacy/no_plan.t b/cpan/Test-Simple/t/Legacy/no_plan.t deleted file mode 100644 index 5f392e40e1..0000000000 --- a/cpan/Test-Simple/t/Legacy/no_plan.t +++ /dev/null @@ -1,33 +0,0 @@ -#!/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/Legacy/no_tests.t b/cpan/Test-Simple/t/Legacy/no_tests.t deleted file mode 100644 index eafa38cacc..0000000000 --- a/cpan/Test-Simple/t/Legacy/no_tests.t +++ /dev/null @@ -1,44 +0,0 @@ -#!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, <is_eq($err->read, <is_eq($?, 255, "exit code"); - - exit grep { !$_ } $TB->summary; -} diff --git a/cpan/Test-Simple/t/Legacy/note.t b/cpan/Test-Simple/t/Legacy/note.t deleted file mode 100644 index fb98fb4029..0000000000 --- a/cpan/Test-Simple/t/Legacy/note.t +++ /dev/null @@ -1,30 +0,0 @@ -#!/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/Legacy/overload.t b/cpan/Test-Simple/t/Legacy/overload.t deleted file mode 100644 index fe9bc46e5a..0000000000 --- a/cpan/Test-Simple/t/Legacy/overload.t +++ /dev/null @@ -1,86 +0,0 @@ -#!/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/Legacy/overload_threads.t b/cpan/Test-Simple/t/Legacy/overload_threads.t deleted file mode 100644 index 379e347bae..0000000000 --- a/cpan/Test-Simple/t/Legacy/overload_threads.t +++ /dev/null @@ -1,60 +0,0 @@ -#!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/Legacy/plan.t b/cpan/Test-Simple/t/Legacy/plan.t deleted file mode 100644 index 2b6b2fdc78..0000000000 --- a/cpan/Test-Simple/t/Legacy/plan.t +++ /dev/null @@ -1,21 +0,0 @@ -#!/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("Tried to plan twice!\n %s line %d\n %s line %d\n", $0, __LINE__ - 2, $0, __LINE__ - 1), - 'disallow double plan' ); -eval { plan 'no_plan' }; -is( $@, sprintf("Tried to plan twice!\n %s line %d\n %s line %d\n", $0, __LINE__ - 5, $0, __LINE__ - 1), - 'disallow changing plan' ); - -pass('Just testing plan()'); -pass('Testing it some more'); diff --git a/cpan/Test-Simple/t/Legacy/plan_bad.t b/cpan/Test-Simple/t/Legacy/plan_bad.t deleted file mode 100644 index 179356dbc1..0000000000 --- a/cpan/Test-Simple/t/Legacy/plan_bad.t +++ /dev/null @@ -1,37 +0,0 @@ -#!/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/Legacy/plan_is_noplan.t b/cpan/Test-Simple/t/Legacy/plan_is_noplan.t deleted file mode 100644 index 1e696042ef..0000000000 --- a/cpan/Test-Simple/t/Legacy/plan_is_noplan.t +++ /dev/null @@ -1,32 +0,0 @@ -#!/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, <can('carp')" ) { - plan skip_all => 'Modern::Open is installed, which breaks this test'; - } - 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/Legacy/plan_shouldnt_import.t b/cpan/Test-Simple/t/Legacy/plan_shouldnt_import.t deleted file mode 100644 index b6eb064244..0000000000 --- a/cpan/Test-Simple/t/Legacy/plan_shouldnt_import.t +++ /dev/null @@ -1,16 +0,0 @@ -#!/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/Legacy/plan_skip_all.t b/cpan/Test-Simple/t/Legacy/plan_skip_all.t deleted file mode 100644 index 528df5f50d..0000000000 --- a/cpan/Test-Simple/t/Legacy/plan_skip_all.t +++ /dev/null @@ -1,12 +0,0 @@ -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/Legacy/pod.t b/cpan/Test-Simple/t/Legacy/pod.t deleted file mode 100644 index ac55c162df..0000000000 --- a/cpan/Test-Simple/t/Legacy/pod.t +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/perl -w - -use Test::More; -plan skip_all => "POD tests skipped unless AUTHOR_TESTING is set" unless $ENV{AUTHOR_TESTING}; -my $test_pod = eval "use Test::Pod 1.00; 1"; -plan skip_all => "Test::Pod 1.00 required for testing POD" unless $test_pod; -all_pod_files_ok(); diff --git a/cpan/Test-Simple/t/Legacy/require_ok.t b/cpan/Test-Simple/t/Legacy/require_ok.t deleted file mode 100644 index 56d01bc108..0000000000 --- a/cpan/Test-Simple/t/Legacy/require_ok.t +++ /dev/null @@ -1,22 +0,0 @@ -#!/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 => 4; - -# 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" ); diff --git a/cpan/Test-Simple/t/Legacy/ribasushi_threads.t b/cpan/Test-Simple/t/Legacy/ribasushi_threads.t deleted file mode 100644 index bbf3b67c3e..0000000000 --- a/cpan/Test-Simple/t/Legacy/ribasushi_threads.t +++ /dev/null @@ -1,44 +0,0 @@ -use Test::CanThread qw/AUTHOR_TESTING/; -use Test::More; - -# basic tests -{ - pass('Test starts'); - my $ct_num = Test::More->builder->current_test; - - my $newthread = async { - my $out = ''; - - #simulate a subtest to not confuse the parent TAP emission - my $tb = Test::More->builder; - $tb->reset; - - Test::More->builder->current_test(0); - for (qw/output failure_output todo_output/) { - close $tb->$_; - open($tb->$_, '>', \$out); - } - - pass("In-thread ok") for (1, 2, 3); - - done_testing; - - close $tb->$_ for (qw/output failure_output todo_output/); - sleep(1); # tasty crashes without this - - $out; - }; - die "Thread creation failed: $! $@" if !defined $newthread; - - my $out = $newthread->join; - $out =~ s/^/ /gm; - - print $out; - - # workaround for older Test::More confusing the plan under threads - Test::More->builder->current_test($ct_num); - - pass("Made it to the end"); -} - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/ribasushi_threads2.t b/cpan/Test-Simple/t/Legacy/ribasushi_threads2.t deleted file mode 100644 index 411a46315d..0000000000 --- a/cpan/Test-Simple/t/Legacy/ribasushi_threads2.t +++ /dev/null @@ -1,21 +0,0 @@ -use strict; -use warnings; - -use Test::CanThread qw/AUTHOR_TESTING/; -use Test::More; - -{ - my $todo = sub { - my $out; - ok(1); - 42; - }; - - is( - threads->create($todo)->join, - 42, - "Correct result after do-er", - ); -} - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/simple.t b/cpan/Test-Simple/t/Legacy/simple.t deleted file mode 100644 index 7297e9d6dd..0000000000 --- a/cpan/Test-Simple/t/Legacy/simple.t +++ /dev/null @@ -1,17 +0,0 @@ -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/Legacy/skip.t b/cpan/Test-Simple/t/Legacy/skip.t deleted file mode 100644 index 18d5541295..0000000000 --- a/cpan/Test-Simple/t/Legacy/skip.t +++ /dev/null @@ -1,106 +0,0 @@ -#!perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - -BEGIN { - require warnings; - if( eval "warnings->can('carp')" ) { - require Test::More; - Test::More::plan( skip_all => 'Modern::Open is installed, which breaks this test' ); - } -} - -use Test::More tests => 16; - -# 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/Legacy/skipall.t b/cpan/Test-Simple/t/Legacy/skipall.t deleted file mode 100644 index 08c8543be2..0000000000 --- a/cpan/Test-Simple/t/Legacy/skipall.t +++ /dev/null @@ -1,33 +0,0 @@ -#!/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/Legacy/strays.t b/cpan/Test-Simple/t/Legacy/strays.t deleted file mode 100644 index 02a99ab996..0000000000 --- a/cpan/Test-Simple/t/Legacy/strays.t +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/perl -w - -# Check that stray newlines in test output are properly handed. - -BEGIN { - print "1..0 # Skip not completed\n"; - exit 0; -} - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} -chdir 't'; - -use Test::Builder::NoOutput; -my $tb = Test::Builder::NoOutput->create; - -$tb->ok(1, "name\n"); -$tb->ok(0, "foo\nbar\nbaz"); -$tb->skip("\nmoofer"); -$tb->todo_skip("foo\n\n"); diff --git a/cpan/Test-Simple/t/Legacy/subtest/args.t b/cpan/Test-Simple/t/Legacy/subtest/args.t deleted file mode 100644 index d43ac5288e..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/args.t +++ /dev/null @@ -1,34 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use Test::Builder; - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ( '../lib', 'lib' ); - } - else { - unshift @INC, 't/lib'; - } -} -use Test::Builder::NoOutput; - -my $tb = Test::Builder->new; - -$tb->ok( !eval { $tb->subtest() } ); -$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); - -$tb->ok( !eval { $tb->subtest("foo") } ); -$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); - -use Carp qw/confess/; -$tb->subtest('Arg passing', sub { - my $foo = shift; - my $child = Test::Builder->new; - $child->is_eq($foo, 'foo'); - $child->done_testing; - $child->finalize; -}, 'foo'); - -$tb->done_testing(); diff --git a/cpan/Test-Simple/t/Legacy/subtest/bail_out.t b/cpan/Test-Simple/t/Legacy/subtest/bail_out.t deleted file mode 100644 index d6b074c2cf..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/bail_out.t +++ /dev/null @@ -1,64 +0,0 @@ -#!/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; die }; -} - -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 => 2); - -plan tests => 4; - -ok 'foo'; -my $ok = eval { - subtest 'bar' => sub { - plan tests => 3; - ok 'sub_foo'; - subtest 'sub_bar' => sub { - plan tests => 3; - ok 'sub_sub_foo'; - ok 'sub_sub_bar'; - BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); - ok 'sub_sub_baz'; - }; - ok 'sub_baz'; - }; - 1; -}; - -$Test->is_eq( $output, <<'OUT' ); -1..4 -ok 1 -# Subtest: bar - 1..3 - ok 1 - # Subtest: sub_bar - 1..3 - ok 1 - ok 2 - Bail out! ROCKS FALL! EVERYONE DIES! - Bail out! ROCKS FALL! EVERYONE DIES! -Bail out! ROCKS FALL! EVERYONE DIES! -OUT - -$Test->is_eq( $Exit_Code, 255 ); diff --git a/cpan/Test-Simple/t/Legacy/subtest/basic.t b/cpan/Test-Simple/t/Legacy/subtest/basic.t deleted file mode 100644 index 92af4dc8f1..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/basic.t +++ /dev/null @@ -1,223 +0,0 @@ -#!/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 => 18; - -# Formatting may change if we're running under Test::Harness. -$ENV{HARNESS_ACTIVE} = 0; - -{ - my $tb = Test::Builder::NoOutput->create; - - $tb->plan( tests => 7 ); - for( 1 .. 3 ) { - $tb->ok( $_, "We're on $_" ); - $tb->diag("We ran $_"); - } - { - my $indented = $tb->child; - $indented->plan('no_plan'); - $indented->ok( 1, "We're on 1" ); - $indented->ok( 1, "We're on 2" ); - $indented->ok( 1, "We're on 3" ); - $indented->finalize; - } - for( 7, 8, 9 ) { - $tb->ok( $_, "We're on $_" ); - } - - is $tb->read, <<"END", 'Output should nest properly'; -1..7 -ok 1 - We're on 1 -# We ran 1 -ok 2 - We're on 2 -# We ran 2 -ok 3 - We're on 3 -# We ran 3 - ok 1 - We're on 1 - ok 2 - We're on 2 - ok 3 - We're on 3 - 1..3 -ok 4 - Child of $0 -ok 5 - We're on 7 -ok 6 - We're on 8 -ok 7 - We're on 9 -END -} -{ - my $tb = Test::Builder::NoOutput->create; - - $tb->plan('no_plan'); - for( 1 .. 1 ) { - $tb->ok( $_, "We're on $_" ); - $tb->diag("We ran $_"); - } - { - my $indented = $tb->child; - $indented->plan('no_plan'); - $indented->ok( 1, "We're on 1" ); - { - my $indented2 = $indented->child('with name'); - $indented2->plan( tests => 2 ); - $indented2->ok( 1, "We're on 2.1" ); - $indented2->ok( 1, "We're on 2.1" ); - $indented2->finalize; - } - $indented->ok( 1, 'after child' ); - $indented->finalize; - } - for(7) { - $tb->ok( $_, "We're on $_" ); - } - - $tb->_ending; - is $tb->read, <<"END", 'We should allow arbitrary nesting'; -ok 1 - We're on 1 -# We ran 1 - ok 1 - We're on 1 - 1..2 - ok 1 - We're on 2.1 - ok 2 - We're on 2.1 - ok 2 - with name - ok 3 - after child - 1..3 -ok 2 - Child of $0 -ok 3 - We're on 7 -1..3 -END -} - -{ -#line 108 - my $tb = Test::Builder::NoOutput->create; - - { - my $child = $tb->child('expected to fail'); - $child->plan( tests => 3 ); - $child->ok(1); - $child->ok(0); - $child->ok(3); - $child->finalize; - } - - { - my $child = $tb->child('expected to pass'); - $child->plan( tests => 3 ); - $child->ok(1); - $child->ok(2); - $child->ok(3); - $child->finalize; - } - is $tb->read, <<"END", 'Previous child failures should not force subsequent failures'; - 1..3 - ok 1 - not ok 2 - # Failed test at $0 line 114. - ok 3 - # Looks like you failed 1 test of 3. -not ok 1 - expected to fail -# Failed test 'expected to fail' -# at $0 line 116. - 1..3 - ok 1 - ok 2 - ok 3 -ok 2 - expected to pass -END -} -{ - my $tb = Test::Builder::NoOutput->create; - my $child = $tb->child('one'); - is $child->{$_}, $tb->{$_}, "The child should copy the ($_) filehandle" - foreach qw{Out_FH Todo_FH Fail_FH}; - $child->finalize; -} -{ - my $tb = Test::Builder::NoOutput->create; - my $child = $tb->child('one'); - can_ok $child, 'parent'; - is $child->parent, $tb, '... and it should return the parent of the child'; - ok !defined $tb->parent, '... but top level builders should not have parents'; - - can_ok $tb, 'name'; - is $tb->name, $0, 'The top level name should be $0'; - is $child->name, 'one', '... but child names should be whatever we set them to'; - $child->finalize; - $child = $tb->child; - is $child->name, 'Child of '.$tb->name, '... or at least have a sensible default'; - $child->finalize; -} -# Skip all subtests -{ - my $tb = Test::Builder::NoOutput->create; - - { - my @warnings; - local $SIG{__WARN__} = sub { push @warnings, $_[0] }; - - my $child = $tb->child('skippy says he loves you'); - eval { $child->plan(skip_all => 'cuz I said so') }; - - is(scalar(@warnings), 1, "one warning"); - like( - $warnings[0], - qr/^SKIP_ALL in subtest could not find flow-control label,/, - "the warning" - ); - } - subtest 'skip all', sub { - plan skip_all => 'subtest with skip_all'; - ok 0, 'This should never be run'; - }; -} - -# to do tests -{ -#line 204 - my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 1 ); - my $child = $tb->child; - $child->plan( tests => 1 ); - $child->todo_start( 'message' ); - $child->ok( 0 ); - $child->todo_end; - $child->finalize; - $tb->_ending; - is $tb->read, <<"END", 'TODO tests should not make the parent test fail'; -1..1 - 1..1 - not ok 1 # TODO message - # Failed (TODO) test at $0 line 209. -ok 1 - Child of $0 -END -} -{ - my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 1 ); - my $child = $tb->child; - $child->finalize; - $tb->_ending; - my $expected = <<"END"; -1..1 -not ok 1 - Child of $0 -# Failed test 'Child of $0' -# at $0 line 225. -# No tests run for subtest. -END - like $tb->read, qr/\Q$expected/, - 'Not running subtests should make the parent test fail'; -} diff --git a/cpan/Test-Simple/t/Legacy/subtest/die.t b/cpan/Test-Simple/t/Legacy/subtest/die.t deleted file mode 100644 index 3d53abf6cc..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/die.t +++ /dev/null @@ -1,30 +0,0 @@ -#!/usr/bin/perl -w - -# What happens when a subtest dies? - -use lib 't/lib'; - -use strict; -use Test::Builder; -use Test::Builder::NoOutput; - -my $Test = Test::Builder->new; - -{ - my $tb = Test::Builder::NoOutput->create; - - $tb->ok(1); - - $Test->ok( !eval { - $tb->subtest("death" => sub { - die "Death in the subtest"; - }); - 1; - }); - $Test->like( $@, qr/^Death in the subtest at \Q$0\E line /); - - $Test->ok( !$tb->parent, "the parent object is restored after a die" ); -} - - -$Test->done_testing(); diff --git a/cpan/Test-Simple/t/Legacy/subtest/do.t b/cpan/Test-Simple/t/Legacy/subtest/do.t deleted file mode 100644 index b034893f63..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/do.t +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/perl -w - -# Test the idiom of running another test file as a subtest. - -use strict; -use Test::More; - -pass("First"); - -my $file = "t/Legacy/subtest/for_do_t.test"; -ok -e $file, "subtest test file exists"; - -subtest $file => sub { do $file }; - -pass("Last"); - -done_testing(4); diff --git a/cpan/Test-Simple/t/Legacy/subtest/exceptions.t b/cpan/Test-Simple/t/Legacy/subtest/exceptions.t deleted file mode 100644 index c4e57a982f..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/exceptions.t +++ /dev/null @@ -1,67 +0,0 @@ -#!/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 => 7; - -{ - my $tb = Test::Builder::NoOutput->create; - my $child = $tb->child('one'); - eval { $tb->child('two') }; - my $error = $@; - like $error, qr/\QYou already have a child named (one) running/, - 'Trying to create a child with another one active should fail'; - $child->finalize; -} -{ - my $tb = Test::Builder::NoOutput->create; - my $child = $tb->child('one'); - ok my $child2 = $child->child('two'), 'Trying to create nested children should succeed'; - eval { $child->finalize }; - my $error = $@; - like $error, qr/\QCan't call finalize() with child (two) active/, - '... but trying to finalize() a child with open children should fail'; - $child2->finalize; - $child->finalize; -} -{ - my $tb = Test::Builder::NoOutput->create; - my $child = $tb->child('one'); - eval { $child->DESTROY }; - like $@, qr/\QChild (one) exited without calling finalize()/, - 'Failing to call finalize should issue an appropriate diagnostic'; - ok !$tb->is_passing, '... and should cause the test suite to fail'; - $child->finalize; -} -{ - my $tb = Test::Builder::NoOutput->create; - - $tb->plan( tests => 7 ); - for( 1 .. 3 ) { - $tb->ok( $_, "We're on $_" ); - $tb->diag("We ran $_"); - } - { - my $indented = $tb->child; - $indented->plan('no_plan'); - $indented->ok( 1, "We're on 1" ); - eval { $tb->ok( 1, 'This should throw an exception' ) }; - $indented->finalize; - } - - my $error = $@; - like $error, qr/\QCannot run test (This should throw an exception) with active children/, - 'Running a test with active children should fail'; - ok !$tb->is_passing, '... and should cause the test suite to fail'; -} diff --git a/cpan/Test-Simple/t/Legacy/subtest/for_do_t.test b/cpan/Test-Simple/t/Legacy/subtest/for_do_t.test deleted file mode 100644 index 413923bceb..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/for_do_t.test +++ /dev/null @@ -1,9 +0,0 @@ -# Test used by t/subtest/do.t - -use Test::More; - -pass("First"); -pass("Second"); -pass("Third"); - -done_testing(3); diff --git a/cpan/Test-Simple/t/Legacy/subtest/fork.t b/cpan/Test-Simple/t/Legacy/subtest/fork.t deleted file mode 100644 index ae1b038c9f..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/fork.t +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/bin/perl -w -use strict; -use warnings; - -use Test::CanFork; - -use IO::Pipe; -use Test::Builder; -use Test::More; - -subtest 'fork within subtest' => sub { - my $pipe = IO::Pipe->new; - - my $pid = fork(); - plan skip_all => "Fork not working" - unless defined $pid; - - if ($pid) { - $pipe->reader; - my $child_output = do { local $/ ; <$pipe> }; - waitpid $pid, 0; - - is $?, 0, 'child exit status'; - like $child_output, qr/^[\s#]+Child Done\s*\z/, 'child output'; - } - else { - $pipe->writer; - - # Force all T::B output into the pipe, for the parent - # builder as well as the current subtest builder. - my $builder = Test::Builder->new; - $builder->output($pipe); - $builder->failure_output($pipe); - $builder->todo_output($pipe); - - diag 'Child Done'; - exit 0; - } -}; - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/subtest/implicit_done.t b/cpan/Test-Simple/t/Legacy/subtest/implicit_done.t deleted file mode 100644 index 0963e72c59..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/implicit_done.t +++ /dev/null @@ -1,31 +0,0 @@ -#!/usr/bin/perl -w - -# A subtest without a plan implicitly calls "done_testing" - -use strict; -use Test::More; - -pass "Before"; - -subtest 'basic' => sub { - pass "Inside sub test"; -}; - -subtest 'with done' => sub { - pass 'This has done_testing'; - done_testing; -}; - -subtest 'with plan' => sub { - plan tests => 1; - pass 'I have a plan, Batman!'; -}; - -subtest 'skipping' => sub { - plan skip_all => 'Skipping'; - fail 'Shouldnt see me!'; -}; - -pass "After"; - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/subtest/line_numbers.t b/cpan/Test-Simple/t/Legacy/subtest/line_numbers.t deleted file mode 100644 index cc9c10db4f..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/line_numbers.t +++ /dev/null @@ -1,131 +0,0 @@ -#!/usr/bin/perl -w - -# Test Test::More::subtest(), focusing on correct line numbers in -# failed test diagnostics. - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ( '../lib', 'lib' ); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use warnings; - -use Test::More tests => 5; -use Test::Builder; -use Test::Builder::Tester; - -# Formatting may change if we're running under Test::Harness. -$ENV{HARNESS_ACTIVE} = 0; - -our %line; - -{ - test_out("# Subtest: namehere"); - test_out(" 1..3"); - test_out(" ok 1"); - test_out(" not ok 2"); - test_err(" # Failed test at $0 line $line{innerfail1}."); - test_out(" ok 3"); - test_err(" # Looks like you failed 1 test of 3."); - test_out("not ok 1 - namehere"); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line $line{outerfail1}."); - - subtest namehere => sub { - plan tests => 3; - ok 1; - ok 0; BEGIN{ $line{innerfail1} = __LINE__ } - ok 1; - }; BEGIN{ $line{outerfail1} = __LINE__ } - - test_test("un-named inner tests"); -} -{ - test_out("# Subtest: namehere"); - test_out(" 1..3"); - test_out(" ok 1 - first is good"); - test_out(" not ok 2 - second is bad"); - test_err(" # Failed test 'second is bad'"); - test_err(" # at $0 line $line{innerfail2}."); - test_out(" ok 3 - third is good"); - test_err(" # Looks like you failed 1 test of 3."); - test_out("not ok 1 - namehere"); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line $line{outerfail2}."); - - subtest namehere => sub { - plan tests => 3; - ok 1, "first is good"; - ok 0, "second is bad"; BEGIN{ $line{innerfail2} = __LINE__ } - ok 1, "third is good"; - }; BEGIN{ $line{outerfail2} = __LINE__ } - - test_test("named inner tests"); -} - -sub run_the_subtest { - subtest namehere => sub { - plan tests => 3; - ok 1, "first is good"; - ok 0, "second is bad"; BEGIN{ $line{innerfail3} = __LINE__ } - ok 1, "third is good"; - }; BEGIN{ $line{outerfail3} = __LINE__ } -} -{ - test_out("# Subtest: namehere"); - test_out(" 1..3"); - test_out(" ok 1 - first is good"); - test_out(" not ok 2 - second is bad"); - test_err(" # Failed test 'second is bad'"); - test_err(" # at $0 line $line{innerfail3}."); - test_out(" ok 3 - third is good"); - test_err(" # Looks like you failed 1 test of 3."); - test_out("not ok 1 - namehere"); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line $line{outerfail3}."); - - run_the_subtest(); - - test_test("subtest() called from a sub"); -} -{ - test_out( "# Subtest: namehere"); - test_out( " 1..0"); - test_err( " # No tests run!"); - test_out( 'not ok 1 - namehere'); - test_err(q{# Failed test 'namehere'}); - test_err( "# at $0 line $line{outerfail4}."); - test_err( "# No tests run for subtest."); - - subtest namehere => sub { - done_testing; - }; BEGIN{ $line{outerfail4} = __LINE__ } - - test_test("lineno in 'No tests run' diagnostic"); -} -{ - test_out("# Subtest: namehere"); - test_out(" 1..1"); - test_out(" not ok 1 - foo is bar"); - test_err(" # Failed test 'foo is bar'"); - test_err(" # at $0 line $line{is_fail}."); - test_err(" # got: 'foo'"); - test_err(" # expected: 'bar'"); - test_err(" # Looks like you failed 1 test of 1."); - test_out('not ok 1 - namehere'); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line $line{is_outer_fail}."); - - subtest namehere => sub { - plan tests => 1; - is 'foo', 'bar', 'foo is bar'; BEGIN{ $line{is_fail} = __LINE__ } - }; BEGIN{ $line{is_outer_fail} = __LINE__ } - - test_test("diag indent for is() in subtest"); -} diff --git a/cpan/Test-Simple/t/Legacy/subtest/plan.t b/cpan/Test-Simple/t/Legacy/subtest/plan.t deleted file mode 100644 index 7e944ab283..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/plan.t +++ /dev/null @@ -1,49 +0,0 @@ -#!/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 => 6; - -# Formatting may change if we're running under Test::Harness. -$ENV{HARNESS_ACTIVE} = 0; - -{ - ok defined &subtest, 'subtest() should be exported to our namespace'; - is prototype('subtest'), undef, '... has no prototype'; - - subtest 'subtest with plan', sub { - plan tests => 2; - ok 1, 'planned subtests should work'; - ok 1, '... and support more than one test'; - }; - subtest 'subtest without plan', sub { - plan 'no_plan'; - ok 1, 'no_plan subtests should work'; - ok 1, '... and support more than one test'; - ok 1, '... no matter how many tests are run'; - }; - subtest 'subtest with implicit done_testing()', sub { - ok 1, 'subtests with an implicit done testing should work'; - ok 1, '... and support more than one test'; - ok 1, '... no matter how many tests are run'; - }; - subtest 'subtest with explicit done_testing()', sub { - ok 1, 'subtests with an explicit done testing should work'; - ok 1, '... and support more than one test'; - ok 1, '... no matter how many tests are run'; - done_testing(); - }; -} diff --git a/cpan/Test-Simple/t/Legacy/subtest/predicate.t b/cpan/Test-Simple/t/Legacy/subtest/predicate.t deleted file mode 100644 index 73b9c81056..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/predicate.t +++ /dev/null @@ -1,166 +0,0 @@ -#!/usr/bin/perl -w - -# Test the use of subtest() to define new test predicates that combine -# multiple existing predicates. - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ( '../lib', 'lib' ); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use warnings; - -use Test::More tests => 5; -use Test::Builder; -use Test::Builder::Tester; - -# Formatting may change if we're running under Test::Harness. -$ENV{HARNESS_ACTIVE} = 0; - -our %line; - -# Define a new test predicate with Test::More::subtest(), using -# Test::More predicates as building blocks... - -sub foobar_ok ($;$) { - my ($value, $name) = @_; - $name ||= "foobar_ok"; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - subtest $name => sub { - plan tests => 2; - ok $value =~ /foo/, "foo"; - ok $value =~ /bar/, "bar"; BEGIN{ $line{foobar_ok_bar} = __LINE__ } - }; -} -{ - test_out("# Subtest: namehere"); - test_out(" 1..2"); - test_out(" ok 1 - foo"); - test_out(" not ok 2 - bar"); - test_err(" # Failed test 'bar'"); - test_err(" # at $0 line $line{foobar_ok_bar}."); - test_err(" # Looks like you failed 1 test of 2."); - test_out("not ok 1 - namehere"); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line ".(__LINE__+2)."."); - - foobar_ok "foot", "namehere"; - - test_test("foobar_ok failing line numbers"); -} - -# Wrap foobar_ok() to make another new predicate... - -sub foobar_ok_2 ($;$) { - my ($value, $name) = @_; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - foobar_ok($value, $name); -} -{ - test_out("# Subtest: namehere"); - test_out(" 1..2"); - test_out(" ok 1 - foo"); - test_out(" not ok 2 - bar"); - test_err(" # Failed test 'bar'"); - test_err(" # at $0 line $line{foobar_ok_bar}."); - test_err(" # Looks like you failed 1 test of 2."); - test_out("not ok 1 - namehere"); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line ".(__LINE__+2)."."); - - foobar_ok_2 "foot", "namehere"; - - test_test("foobar_ok_2 failing line numbers"); -} - -# Define another new test predicate, this time using -# Test::Builder::subtest() rather than Test::More::subtest()... - -sub barfoo_ok ($;$) { - my ($value, $name) = @_; - $name ||= "barfoo_ok"; - - Test::Builder->new->subtest($name => sub { - plan tests => 2; - ok $value =~ /foo/, "foo"; - ok $value =~ /bar/, "bar"; BEGIN{ $line{barfoo_ok_bar} = __LINE__ } - }); -} -{ - test_out("# Subtest: namehere"); - test_out(" 1..2"); - test_out(" ok 1 - foo"); - test_out(" not ok 2 - bar"); - test_err(" # Failed test 'bar'"); - test_err(" # at $0 line $line{barfoo_ok_bar}."); - test_err(" # Looks like you failed 1 test of 2."); - test_out("not ok 1 - namehere"); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line ".(__LINE__+2)."."); - - barfoo_ok "foot", "namehere"; - - test_test("barfoo_ok failing line numbers"); -} - -# Wrap barfoo_ok() to make another new predicate... - -sub barfoo_ok_2 ($;$) { - my ($value, $name) = @_; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - barfoo_ok($value, $name); -} -{ - test_out("# Subtest: namehere"); - test_out(" 1..2"); - test_out(" ok 1 - foo"); - test_out(" not ok 2 - bar"); - test_err(" # Failed test 'bar'"); - test_err(" # at $0 line $line{barfoo_ok_bar}."); - test_err(" # Looks like you failed 1 test of 2."); - test_out("not ok 1 - namehere"); - test_err("# Failed test 'namehere'"); - test_err("# at $0 line ".(__LINE__+2)."."); - - barfoo_ok_2 "foot", "namehere"; - - test_test("barfoo_ok_2 failing line numbers"); -} - -# A subtest-based predicate called from within a subtest -{ - test_out("# Subtest: outergroup"); - test_out(" 1..2"); - test_out(" ok 1 - this passes"); - test_out(" # Subtest: namehere"); - test_out(" 1..2"); - test_out(" ok 1 - foo"); - test_out(" not ok 2 - bar"); - test_err(" # Failed test 'bar'"); - test_err(" # at $0 line $line{barfoo_ok_bar}."); - test_err(" # Looks like you failed 1 test of 2."); - test_out(" not ok 2 - namehere"); - test_err(" # Failed test 'namehere'"); - test_err(" # at $0 line $line{ipredcall}."); - test_err(" # Looks like you failed 1 test of 2."); - test_out("not ok 1 - outergroup"); - test_err("# Failed test 'outergroup'"); - test_err("# at $0 line $line{outercall}."); - - subtest outergroup => sub { - plan tests => 2; - ok 1, "this passes"; - barfoo_ok_2 "foot", "namehere"; BEGIN{ $line{ipredcall} = __LINE__ } - }; BEGIN{ $line{outercall} = __LINE__ } - - test_test("outergroup with internal barfoo_ok_2 failing line numbers"); -} diff --git a/cpan/Test-Simple/t/Legacy/subtest/singleton.t b/cpan/Test-Simple/t/Legacy/subtest/singleton.t deleted file mode 100644 index 0c25261f5b..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/singleton.t +++ /dev/null @@ -1,38 +0,0 @@ -#!/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 => 3; - -{ - - package Test::Singleton; - - use Test::Builder; - my $TB = Test::Builder->new; - - sub singleton_ok ($;$) { - my( $val, $name ) = @_; - $TB->ok( $val, $name ); - } -} - -ok 1, 'TB top level'; -subtest 'doing a subtest' => sub { - plan tests => 4; - ok 1, 'first test in subtest'; - Test::Singleton::singleton_ok(1, 'this should not fail'); - ok 1, 'second test in subtest'; - Test::Singleton::singleton_ok(1, 'this should not fail'); -}; -ok 1, 'left subtest'; diff --git a/cpan/Test-Simple/t/Legacy/subtest/threads.t b/cpan/Test-Simple/t/Legacy/subtest/threads.t deleted file mode 100644 index df00f40c04..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/threads.t +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use warnings; - -use Test::CanThread; - -use Test::More; - -subtest 'simple test with threads on' => sub { - is( 1+1, 2, "simple test" ); - is( "a", "a", "another simple test" ); -}; - -pass("Parent retains sharedness"); - -done_testing(2); diff --git a/cpan/Test-Simple/t/Legacy/subtest/todo.t b/cpan/Test-Simple/t/Legacy/subtest/todo.t deleted file mode 100644 index 82de40e3da..0000000000 --- a/cpan/Test-Simple/t/Legacy/subtest/todo.t +++ /dev/null @@ -1,204 +0,0 @@ -#!/usr/bin/perl -w - -# Test todo subtests. -# -# A subtest in a todo context should have all of its diagnostic output -# redirected to the todo output destination, but individual tests -# within the subtest should not become todo tests themselves. - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ( '../lib', 'lib' ); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use warnings; - -use Test::More; -use Test::Builder; -use Test::Builder::Tester; - -# Formatting may change if we're running under Test::Harness. -$ENV{HARNESS_ACTIVE} = 0; - -our %line; - -# Repeat each test for various combinations of the todo reason, -# the mechanism by which it is set and $Level. -our @test_combos; -foreach my $level (1, 2, 3) { - push @test_combos, ['$TODO', 'Reason', $level], - ['todo_start', 'Reason', $level], - ['todo_start', '', $level], - ['todo_start', 0, $level]; -} - -plan tests => 8 * @test_combos; - -sub test_subtest_in_todo { - my ($name, $code, $want_out, $no_tests_run) = @_; - - #my $xxx = $no_tests_run ? 'No tests run for subtest "xxx"' : 'xxx'; - my @no_test_err = $no_tests_run ? ('# No tests run for subtest.') : (); - - chomp $want_out; - my @outlines = split /\n/, $want_out; - - foreach my $combo (@test_combos) { - my ($set_via, $todo_reason, $level) = @$combo; - - test_out( - "# Subtest: xxx", - @outlines, - map { my $x = $_; $x =~ s/\s+$//; $x } ( - "not ok 1 - xxx # TODO $todo_reason", - "# Failed (TODO) test 'xxx'", - "# at $0 line $line{xxx}.", - @no_test_err, - "not ok 2 - regular todo test # TODO $todo_reason", - "# Failed (TODO) test 'regular todo test'", - "# at $0 line $line{reg}.", - ) - ); - - { - local $TODO = $set_via eq '$TODO' ? $todo_reason : undef; - if ($set_via eq 'todo_start') { - Test::Builder->new->todo_start($todo_reason); - } - - subtest_at_level( - 'xxx', $code, $level); BEGIN{ $line{xxx} = __LINE__ } - ok 0, 'regular todo test'; BEGIN{ $line{reg} = __LINE__ } - - if ($set_via eq 'todo_start') { - Test::Builder->new->todo_end; - } - } - - last unless test_test("$name ($level), todo [$todo_reason] set via $set_via"); - } -} - -package Foo; # If several stack frames are in package 'main' then $Level - # could be wrong and $main::TODO might still be found. Using - # another package makes the tests more sensitive. - -sub main::subtest_at_level { - my ($name, $code, $level) = @_; - - if ($level > 1) { - local $Test::Builder::Level = $Test::Builder::Level + 1; - main::subtest_at_level($name, $code, $level-1); - } - else { - Test::Builder->new->subtest($name => $code); - } -} - -package main; - -test_subtest_in_todo("plan, no tests run", sub { - plan tests => 2; -}, < 17; - ok 0, 'failme'; BEGIN { $line{fail2} = __LINE__ } -}, <new->todo_start('Inner2'); - ok 0, 'failing TODO b'; BEGIN{ $line{ftb} = __LINE__ } - ok 1, 'unexpected pass b'; - Test::Builder->new->todo_end; - - ok 0, 'inner test 3'; BEGIN{ $line{in3} = __LINE__ } -}, < sub { - plan tests => 1; - $? = 1; - pass('bar'); -}; - -is $?, 1, "exit code keeps on from a subtest"; - -subtest foo2 => sub { - plan tests => 1; - pass('bar2'); - $? = 1; -}; - -is $?, 1, "exit code keeps on from a subtest"; - -done_testing(4); diff --git a/cpan/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t b/cpan/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t deleted file mode 100644 index 4202a69926..0000000000 --- a/cpan/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t +++ /dev/null @@ -1,24 +0,0 @@ -#!/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/Legacy/test_use_ok.t b/cpan/Test-Simple/t/Legacy/test_use_ok.t deleted file mode 100644 index 0b4b9a7d35..0000000000 --- a/cpan/Test-Simple/t/Legacy/test_use_ok.t +++ /dev/null @@ -1,40 +0,0 @@ -use strict; -use Test::More; -use ok; -use ok 'strict'; -use ok 'Test::More'; -use ok 'ok'; - -my $class = 'Test::Builder'; -BEGIN { - ok(!$class, '$class is declared, but not yet set'); - - - my $success = eval 'use ok $class'; - my $error = $@; - - ok(!$success, "Threw an exception"); - like( - $error, - qr/^'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable\?/, - "Threw expected exception" - ); - - - - $success = eval 'use ok $class, "xxx"'; - $error = $@; - - ok(!$success, "Threw an exception"); - like( - $error, - qr/^'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable\?/, - "Threw expected exception when arguments are added" - ); -} - -my $class2; -BEGIN {$class2 = 'Test::Builder'}; -use ok $class2; - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/thread_taint.t b/cpan/Test-Simple/t/Legacy/thread_taint.t deleted file mode 100644 index ef7b89daef..0000000000 --- a/cpan/Test-Simple/t/Legacy/thread_taint.t +++ /dev/null @@ -1,5 +0,0 @@ -#!/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/Legacy/threads.t b/cpan/Test-Simple/t/Legacy/threads.t deleted file mode 100644 index 28b0bd1d61..0000000000 --- a/cpan/Test-Simple/t/Legacy/threads.t +++ /dev/null @@ -1,25 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - -use Test::CanThread qw/AUTHOR_TESTING/; - -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/Legacy/todo.t b/cpan/Test-Simple/t/Legacy/todo.t deleted file mode 100644 index 9b5aa7583c..0000000000 --- a/cpan/Test-Simple/t/Legacy/todo.t +++ /dev/null @@ -1,165 +0,0 @@ -#!perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - -use Test::More; - -BEGIN { - require warnings; - if( eval "warnings->can('carp')" ) { - plan skip_all => 'Modern::Open is installed, which breaks this test'; - } -} - -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()"; -} - -# line 200 -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/Legacy/undef.t b/cpan/Test-Simple/t/Legacy/undef.t deleted file mode 100644 index d560f8231c..0000000000 --- a/cpan/Test-Simple/t/Legacy/undef.t +++ /dev/null @@ -1,107 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = ('../lib', 'lib'); - } - else { - unshift @INC, 't/lib'; - } -} - -use strict; -use Test::More; - -BEGIN { - require warnings; - if( eval "warnings->can('carp')" ) { - plan skip_all => 'Modern::Open is installed, which breaks this test'; - } -} - -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' ); -no_warnings; - -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 74 -cmp_ok( undef, '<=', 2, ' undef <= 2' ); -warnings_like(qr/Use of uninitialized value.* at \(eval in cmp_ok\) $Filename line 74\.\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; -} - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/use_ok.t b/cpan/Test-Simple/t/Legacy/use_ok.t deleted file mode 100644 index 9e858bc75e..0000000000 --- a/cpan/Test-Simple/t/Legacy/use_ok.t +++ /dev/null @@ -1,103 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use warnings; - -use lib 't/lib'; -use Test::More; - -note "Basic use_ok"; { - package Foo::one; - ::use_ok("Symbol"); - ::ok( defined &gensym, 'use_ok() no args exports defaults' ); -} - - -note "With one arg"; { - package Foo::two; - ::use_ok("Symbol", qw(qualify)); - ::ok( !defined &gensym, ' one arg, defaults overridden' ); - ::ok( defined &qualify, ' right function exported' ); -} - - -note "Multiple args"; { - package Foo::three; - ::use_ok("Symbol", qw(gensym ungensym)); - ::ok( defined &gensym && defined &ungensym, ' multiple args' ); -} - - -note "Defining constants"; { - 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'); -} - - -note "use Module VERSION"; { - package Foo::five; - ::use_ok("Symbol", 1.02); -} - - -note "use Module VERSION does not call import"; { - 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); -} - - -note "Signals are preserved"; { - package Foo::eight; - local $SIG{__DIE__}; - ::use_ok("SigDie"); - ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved'); -} - - -note "Line numbers preserved"; { - my $package = "that_cares_about_line_numbers"; - - # Store the output of caller. - my @caller; - { - package that_cares_about_line_numbers; - - sub import { - @caller = caller; - return; - } - - $INC{"$package.pm"} = 1; # fool use into thinking it's already loaded - } - - ::use_ok($package); - my $line = __LINE__-1; - ::is( $caller[0], __PACKAGE__, "caller package preserved" ); - ::is( $caller[1], __FILE__, " file" ); - ::is( $caller[2], $line, " line" ); -} - - -note "not confused by functions vs class names"; { - $INC{"ok.pm"} = 1; - use_ok("ok"); # ok is a function inside Test::More - - $INC{"Foo/bar.pm"} = 1; - sub Foo::bar { 42 } - use_ok("Foo::bar"); # Confusing a class name with a function name -} - -done_testing; diff --git a/cpan/Test-Simple/t/Legacy/useing.t b/cpan/Test-Simple/t/Legacy/useing.t deleted file mode 100644 index c4ce507127..0000000000 --- a/cpan/Test-Simple/t/Legacy/useing.t +++ /dev/null @@ -1,19 +0,0 @@ -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/Legacy/utf8.t b/cpan/Test-Simple/t/Legacy/utf8.t deleted file mode 100644 index 2930226e3e..0000000000 --- a/cpan/Test-Simple/t/Legacy/utf8.t +++ /dev/null @@ -1,67 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; - } -} - -use strict; -use warnings; - -my $have_perlio; -BEGIN { - # All together so Test::More sees the open discipline - $have_perlio = eval q[ - require PerlIO; - binmode *STDOUT, ":encoding(utf8)"; - binmode *STDERR, ":encoding(utf8)"; - require 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"; - } -} - - -# Test utf8 is ok. -{ - 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/Legacy/versions.t b/cpan/Test-Simple/t/Legacy/versions.t deleted file mode 100644 index 49e146ad9c..0000000000 --- a/cpan/Test-Simple/t/Legacy/versions.t +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/perl -w - -# Make sure all the modules have the same version -# -# TBT has its own version system. - -use strict; -use Test::More; - -{ - local $SIG{__WARN__} = sub { 1 }; - require Test::Builder::Module; - require Test::Builder::Tester::Color; - require Test::Builder::Tester; - require Test::Builder; - require Test::More; - require Test::Simple; - require Test::Stream; - require Test::Stream::Tester; - require Test::Tester; - require Test::use::ok; - require ok; -} - -my $dist_version = Test::More->VERSION; - -like( $dist_version, qr/^ \d+ \. \d+ $/x, "Version number is sane" ); - -my @modules = qw( - Test::Builder::Module - Test::Builder::Tester::Color - Test::Builder::Tester - Test::Builder - Test::More - Test::Simple - Test::Stream - Test::Stream::Tester - Test::Tester - Test::use::ok - ok -); - -for my $module (@modules) { - my $file = $module; - $file =~ s{(::|')}{/}g; - $file .= ".pm"; - is( $module->VERSION, $module->VERSION, sprintf("%-22s %s", $module, $INC{$file}) ); -} - -done_testing(); diff --git a/cpan/Test-Simple/t/More.t b/cpan/Test-Simple/t/More.t new file mode 100644 index 0000000000..ce535e26d9 --- /dev/null +++ b/cpan/Test-Simple/t/More.t @@ -0,0 +1,184 @@ +#!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 => 54; + +# 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] } + ); + + +# rt.cpan.org 53469 is_deeply with regexes +is_deeply( qr/a/, qr/a/, "same regex" ); + + +# These two tests must remain at the end. +is( $@, $Err, '$@ untouched' ); +cmp_ok( $!, '==', $Errno, '$! untouched' ); diff --git a/cpan/Test-Simple/t/MyTest.pm b/cpan/Test-Simple/t/MyTest.pm new file mode 100644 index 0000000000..e8ad8a3e53 --- /dev/null +++ b/cpan/Test-Simple/t/MyTest.pm @@ -0,0 +1,15 @@ +use strict; +use warnings; + +package MyTest; + +use Test::Builder; + +my $Test = Test::Builder->new; + +sub ok +{ + $Test->ok(@_); +} + +1; diff --git a/cpan/Test-Simple/t/Simple/load.t b/cpan/Test-Simple/t/Simple/load.t new file mode 100644 index 0000000000..938569a5b8 --- /dev/null +++ b/cpan/Test-Simple/t/Simple/load.t @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +# Because I broke "use Test::Simple", here's a test + +use strict; +use warnings; + +use Test::Simple; + +print <new; + +sub ok +{ + $Test->ok(@_); +} + +sub is_eq +{ + $Test->is_eq(@_); +} + +sub is_num +{ + $Test->is_num(@_); +} + +sub getTest +{ + return $Test; +} +1; diff --git a/cpan/Test-Simple/t/Test-Builder.t b/cpan/Test-Simple/t/Test-Builder.t deleted file mode 100644 index 80d19467be..0000000000 --- a/cpan/Test-Simple/t/Test-Builder.t +++ /dev/null @@ -1,10 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -use ok 'Test::Builder'; - -# Test::Builder is tested by the stuff in t/Legacy - -done_testing; diff --git a/cpan/Test-Simple/t/Test-More-DeepCheck.t b/cpan/Test-Simple/t/Test-More-DeepCheck.t deleted file mode 100644 index 9b5bbf8f5d..0000000000 --- a/cpan/Test-Simple/t/Test-More-DeepCheck.t +++ /dev/null @@ -1,7 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use ok 'Test::More::DeepCheck'; - -done_testing; diff --git a/cpan/Test-Simple/t/Test-More.t b/cpan/Test-Simple/t/Test-More.t deleted file mode 100644 index 1522f6f77a..0000000000 --- a/cpan/Test-Simple/t/Test-More.t +++ /dev/null @@ -1,29 +0,0 @@ -use strict; -use warnings; - -use ok 'Test::More'; - -{ - package Foo; - use Test::More import => ['!explain']; -} - -{ - package Bar; - BEGIN { main::use_ok('Scalar::Util', 'blessed') } - BEGIN { main::can_ok('Bar', qw/blessed/) } - blessed('x'); -} - -{ - package Baz; - use Test::More; - use_ok( 'Data::Dumper' ); - can_ok( __PACKAGE__, 'Dumper' ); - Dumper({foo => 'bar'}); -} - -can_ok('Foo', qw/ok is plan/); -ok(!Foo->can('explain'), "explain was not imported"); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-MostlyLike.t b/cpan/Test-Simple/t/Test-MostlyLike.t deleted file mode 100644 index b73a410caf..0000000000 --- a/cpan/Test-Simple/t/Test-MostlyLike.t +++ /dev/null @@ -1,159 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::MostlyLike; -use Test::More; -use Test::Stream::Tester; - -use ok 'Test::MostlyLike'; - -{ - package XXX; - - sub new { bless {ref => ['a']}, shift }; - - sub numbers { 1 .. 10 }; - sub letters { 'a' .. 'e' }; - sub ref { [ 1 .. 10 ] }; -} - -events_are ( - intercept { - mostly_like( 'a', 'a', "match" ); - mostly_like( 'a', 'b', "no match" ); - - mostly_like( - [ qw/a b c/ ], - [ qw/a b c/ ], - "all match", - ); - - mostly_like( - [qw/a b c/], - { 1 => 'b' }, - "Only check one index (match)", - ); - mostly_like( - [qw/a b c/], - { 1 => 'x' }, - "Only check one index (no match)", - ); - - mostly_like( - { a => 1, b => 2, c => 3 }, - { a => 1, b => 2, c => 3 }, - "all match" - ); - - mostly_like( - { a => 1, b => 2, c => 3 }, - { b => 2, d => undef }, - "A match and an expected empty" - ); - - mostly_like( - { a => 1, b => 2, c => 3 }, - { b => undef }, - "Expect empty (fail)" - ); - - mostly_like( - { a => 'foo', b => 'bar' }, - { a => qr/o/, b => qr/a/ }, - "Regex check" - ); - - mostly_like( - { a => 'foo', b => 'bar' }, - { a => qr/o/, b => qr/o/ }, - "Regex check fail" - ); - - mostly_like( - { a => { b => { c => { d => 1 }}}}, - { a => { b => { c => { d => 1 }}}}, - "Deep match" - ); - - mostly_like( - { a => { b => { c => { d => 1 }}}}, - { a => { b => { c => { d => 2 }}}}, - "Deep mismatch" - ); - - mostly_like( - XXX->new, - { - ':ref' => ['a'], - ref => [ 1 .. 10 ], - '[numbers]' => [ 1 .. 10 ], - '[letters]' => [ 'a' .. 'e' ], - }, - "Object check" - ); - - mostly_like( - XXX->new, - { - ':ref' => ['a'], - ref => [ 1 .. 10 ], - '[numbers]' => [ 1 .. 10 ], - '[letters]' => [ 'a' .. 'e' ], - '[invalid]' => [ 'x' ], - }, - "Object check" - ); - - }, - check { - event ok => { bool => 1 }; - event ok => { - bool => 0, - diag => qr/got: 'a'.*\n.*expected: 'b'/, - }; - - event ok => { bool => 1 }; - event ok => { bool => 1 }; - - event ok => { - bool => 0, - diag => qr/\$got->\[1\] = 'b'\n\s*\$expected->\[1\] = 'x'/, - }; - - event ok => { bool => 1 }; - event ok => { bool => 1 }; - - event ok => { - bool => 0, - diag => qr/\$got->\{b\} = '2'\n\s*\$expected->\{b\} = undef/, - }; - - event ok => { bool => 1 }; - event ok => { - bool => 0, - diag => qr/\$got->\{b\} = 'bar'\n\s+\$expected->\{b\} = .*o/, - }; - - event ok => { bool => 1 }; - event ok => { - bool => 0, - diag => qr/\$got->\Q{a}{b}{c}{d}\E = '1'\n\s+\$expected->\Q{a}{b}{c}{d}\E = '2'/, - }; - - event ok => { bool => 1 }; - event ok => { - bool => 0, - diag => [ - qr/\[\s+\$got->invalid\(\)\] = '\(EXCEPTION\)'/, - qr/\[\$expected->\{invalid\}\] = ARRAY/, - qr/Can't locate object method "invalid" via package "XXX"/, - ], - }; - - directive 'end'; - }, - "Tolerant" -); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Simple.t b/cpan/Test-Simple/t/Test-Simple.t deleted file mode 100644 index 8e1fe7ddb1..0000000000 --- a/cpan/Test-Simple/t/Test-Simple.t +++ /dev/null @@ -1,24 +0,0 @@ -use strict; -use warnings; - -use Test::Simple tests => 1; -use Test::Stream::Tester; - -events_are ( - intercept { - ok(1, "Pass"); - ok(0, "Fail"); - }, - check { - event ok => { - bool => 1, - name => 'Pass', - diag => '', - }; - event ok => { - bool => 0, - name => 'Fail', - diag => qr/Failed test 'Fail'/, - }; - }, -); diff --git a/cpan/Test-Simple/t/Test-Stream-API.t b/cpan/Test-Simple/t/Test-Stream-API.t deleted file mode 100644 index 318af7e06b..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-API.t +++ /dev/null @@ -1,323 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; -use Test::Stream::Tester qw/events_are event directive check/; -use Test::MostlyLike; - -require Test::Builder; -require Test::CanFork; - -use Test::Stream::API qw{ - listen munge follow_up - enable_forking cull - peek_todo push_todo pop_todo set_todo inspect_todo - is_tester init_tester - is_modern set_modern - context peek_context clear_context set_context - intercept - state_count state_failed state_plan state_ended is_passing - current_stream - - disable_tap enable_tap subtest_tap_instant subtest_tap_delayed tap_encoding - enable_numbers disable_numbers set_tap_outputs get_tap_outputs -}; - -can_ok(__PACKAGE__, qw{ - listen munge follow_up - enable_forking cull - peek_todo push_todo pop_todo set_todo inspect_todo - is_tester init_tester - is_modern set_modern - context peek_context clear_context set_context - intercept - state_count state_failed state_plan state_ended is_passing - current_stream - - disable_tap enable_tap subtest_tap_instant subtest_tap_delayed tap_encoding - enable_numbers disable_numbers set_tap_outputs get_tap_outputs -}); - -ok(!is_tester('My::Tester'), "Not a tester"); -isa_ok(init_tester('My::Tester'), 'Test::Stream::Meta'); -isa_ok(is_tester('My::Tester'), 'Test::Stream::Meta'); - -ok(!is_modern('My::Tester'), "Not a modern tester"); -set_modern('My::Tester', 1); -ok(is_modern('My::Tester'), "a modern tester"); -set_modern('My::Tester', 0); -ok(!is_modern('My::Tester'), "Not a modern tester"); - -ok(my $ctx = context(), "Got context"); -isa_ok($ctx, 'Test::Stream::Context'); -is(context(), $ctx, "Got the same instance again"); -is(peek_context(), $ctx, "peek"); -my $ref = "$ctx"; - -clear_context(); -my $ne = context() . "" ne $ref; -ok($ne, "cleared"); - -set_context($ctx); -is(context(), $ctx, "Got the same instance again"); - -$ctx = undef; -$ne = context() . "" ne $ref; -ok($ne, "New instance"); - -isa_ok(current_stream(), 'Test::Stream'); - -my @munge; -my @listen; -my @follow; -intercept { - munge { push @munge => $_[1] }; - listen { push @listen => $_[1] }; - - follow_up { push @follow => $_[0]->snapshot }; - - ok(1, "pass"); - diag "foo"; - - done_testing; -}; - -is(@listen, 3, "listen got 3 events"); -is(@munge, 3, "munge got 3 events"); -is(@follow, 1, "Follow was triggered"); - -my $want = check { - event ok => { bool => 1 }; - event diag => { message => 'foo' }; - event plan => { max => 1 }; - directive 'end'; -}; -events_are( \@listen, $want, "Listen events" ); -events_are( \@munge, $want, "Munge events" ); -isa_ok($follow[0], 'Test::Stream::Context'); - -my $events = intercept { - Test::CanFork->import; - - enable_forking; - - my $pid = fork(); - if ($pid) { # Parent - waitpid($pid, 0); - cull; - ok(1, "From Parent"); - } - else { # child - ok(1, "From Child"); - exit 0; - } -}; - -if (@$events == 1) { - events_are ( - $events, - check { - event plan => {}; - }, - "Not testing forking" - ); -} -else { - events_are ( - $events, - check { - event ok => { name => 'From Child' }; - event ok => { name => 'From Parent' }; - }, - "Got forked events" - ); -} - -events_are( - intercept { - ok(0, "fail"); - push_todo('foo'); - ok(0, "fail"); - push_todo('bar'); - ok(0, "fail"); - is(peek_todo(), 'bar', "peek works"); - pop_todo(); - ok(0, "fail"); - pop_todo(); - ok(0, "fail"); - }, - check { - event ok => {todo => '', in_todo => 0}; - event ok => {todo => 'foo', in_todo => 1}; - event ok => {todo => 'bar', in_todo => 1}; - event ok => {bool => 1, real_bool => 1}; # Verify peek - event ok => {todo => 'foo', in_todo => 1}; - event ok => {todo => '', in_todo => 0}; - }, - "Verified TODO stack" -); - -my $meta = init_tester('My::Tester'); -ok(!$meta->todo, "Package is not in todo"); -set_todo('My::Tester', 'foo'); -is($meta->todo, 'foo', "Package is in todo"); - -my @todos = ( - inspect_todo, - inspect_todo('My::Tester'), -); -push_todo('foo'); -push_todo('bar'); -Test::Builder->new->todo_start('tb todo'); -$My::Tester::TODO = 'pkg todo'; -push @todos => inspect_todo, inspect_todo('My::Tester'); -$My::Tester::TODO = undef; -Test::Builder->new->todo_end(); -pop_todo; -pop_todo; -set_todo('My::Tester', undef); -push @todos => inspect_todo, inspect_todo('My::Tester'); - -is_deeply( - \@todos, - [ - { - TB => undef, - TODO => [], - }, - { - META => 'foo', - PKG => undef, - TB => undef, - TODO => [], - }, - { - TB => 'tb todo', - TODO => [qw/foo bar/], - }, - { - META => 'foo', - PKG => 'pkg todo', - TB => 'tb todo', - TODO => [qw/foo bar/], - }, - { - TB => undef, - TODO => [], - }, - { - META => undef, - PKG => undef, - TB => undef, - TODO => [], - } - ], - "Todo state from inspect todo" -); - -my @state; -intercept { - plan tests => 3; - ok(1, "pass"); - ok(2, "pass"); - - push @state => { - count => state_count() || 0, - failed => state_failed() || 0, - plan => state_plan() || undef, - ended => state_ended() || undef, - passing => is_passing(), - }; - - ok(0, "fail"); - done_testing; - - push @state => { - count => state_count() || 0, - failed => state_failed() || 0, - plan => state_plan() || undef, - ended => state_ended() || undef, - passing => is_passing(), - }; -}; - -mostly_like( - \@state, - [ - { count => 2, failed => 0, passing => 1, ended => undef }, - { count => 3, failed => 1, passing => 0 }, - ], - "Verified Test state" -); - -events_are( - [ $state[0]->{plan}, $state[1]->{plan} ], - check { - event plan => { max => 3 }; - event plan => { max => 3 }; - }, - "Parts of state that are events check out." -); - -isa_ok( $state[1]->{ended}, 'Test::Stream::Context' ); - -my $got; -my $results = ""; -my $utf8 = ""; -open( my $fh, ">>", \$results ) || die "Could not open handle to scalar!"; -open( my $fh_utf8, ">>", \$utf8 ) || die "Could not open handle to scalar!"; - -intercept { - enable_tap(); # Disabled by default in intercept() - set_tap_outputs( std => $fh, err => $fh, todo => $fh ); - $got = get_tap_outputs(); - - ok(1, "pass"); - - disable_tap(); - ok(0, "fail"); - - enable_tap(); - tap_encoding('utf8'); - set_tap_outputs( encoding => 'utf8', std => $fh_utf8, err => $fh_utf8, todo => $fh_utf8 ); - ok(1, "pass"); - tap_encoding('legacy'); - - disable_numbers(); - ok(1, "pass"); - enable_numbers(); - ok(1, "pass"); - - subtest_tap_instant(); - subtest foo => sub { ok(1, 'pass') }; - - subtest_tap_delayed(); - subtest foo => sub { ok(1, 'pass') }; -}; - -is_deeply( - $got, - { encoding => 'legacy', std => $fh, err => $fh, todo => $fh }, - "Got outputs" -); - -is( $results, < [qw/foo bar baz/], - ); - - use Test::More; - is(FOO, 0, "FOO CONSTANT"); - is(BAR, 1, "BAR CONSTANT"); - is(BAZ, 2, "BAZ CONSTANT"); - - my $bad = eval { Test::Stream::ArrayBase->import( accessors => [qw/foo/] ); 1 }; - my $error = $@; - ok(!$bad, "Threw exception"); - like($error, qr/field 'foo' already defined/, "Expected error"); -} - -BEGIN { - package My::ABaseSub; - use Test::Stream::ArrayBase( - accessors => [qw/apple pear/], - base => 'My::ABase', - ); - - use Test::More; - is(FOO, 0, "FOO CONSTANT"); - is(BAR, 1, "BAR CONSTANT"); - is(BAZ, 2, "BAZ CONSTANT"); - is(APPLE, 3, "APPLE CONSTANT"); - is(PEAR, 4, "PEAR CONSTANT"); - - my $bad = eval { Test::Stream::ArrayBase->import( base => 'foobarbaz' ); 1 }; - my $error = $@; - ok(!$bad, "Threw exception"); - like($error, qr/My::ABaseSub is already a subclass of 'My::ABase'/, "Expected error"); -} - -{ - package My::ABase; - my $bad = eval { Test::Stream::ArrayBase->import( accessors => [qw/xerxes/] ); 1 }; - my $error = $@; - ok(!$bad, "Threw exception"); - like($error, qr/Cannot add accessor, metadata is locked due to a subclass being initialized/, "Expected error"); -} - -{ - package Consumer; - use My::ABase qw/BAR/; - use Test::More; - - is(BAR, 1, "Can import contants"); - - my $bad = eval { Test::Stream::ArrayBase->import( base => 'Test::More' ); 1 }; - my $error = $@; - ok(!$bad, "Threw exception"); - like($error, qr/Base class 'Test::More' is not a subclass of Test::Stream::ArrayBase/, "Expected error"); -} - -isa_ok('My::ABase', 'Test::Stream::ArrayBase'); -isa_ok('My::ABaseSub', 'Test::Stream::ArrayBase'); -isa_ok('My::ABaseSub', 'My::ABase'); - -my $one = My::ABase->new(qw/a b c/); -is($one->foo, 'a', "Accessor"); -is($one->bar, 'b', "Accessor"); -is($one->baz, 'c', "Accessor"); -$one->set_foo('x'); -is($one->foo, 'x', "Accessor set"); -$one->set_foo(undef); - -is_deeply( - $one->to_hash, - { - foo => undef, - bar => 'b', - baz => 'c', - }, - 'to_hash' -); - -my $two = My::ABase->new_from_pairs( - foo => 'foo', - bar => 'bar', -); - -is($two->foo, 'foo', "set by pair"); -is($two->bar, 'bar', "set by pair"); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Block.t b/cpan/Test-Simple/t/Test-Stream-Block.t deleted file mode 100644 index e181024a74..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Block.t +++ /dev/null @@ -1,108 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -use ok 'Test::Stream::Block'; - -our %BLOCKS; -our %STARTS; -our %ENDS; - -is(keys %BLOCKS, 6, "created 6 blocks"); - -isa_ok($_, 'Test::Stream::Block') for values %BLOCKS; - -is($BLOCKS{one}->start_line, $STARTS{one}, "got start line for block one"); -is($BLOCKS{one}->end_line, $STARTS{two} - 1, "got end line for block one"); - -is($BLOCKS{two}->start_line, $STARTS{two}, "got start line for block two"); -is($BLOCKS{two}->end_line, $ENDS{two}, "got end line for block two"); - -ok($BLOCKS{three}->start_line > $ENDS{two}, "got start line for block three"); -ok($BLOCKS{three}->end_line < $STARTS{four}, "got end line for block three"); - -is($BLOCKS{four}->start_line, $STARTS{four}, "got start line for block four"); -is($BLOCKS{four}->end_line, $STARTS{four}, "got end line for block four"); - -is($BLOCKS{five}->start_line, $STARTS{five}, "got start line for block five"); -is($BLOCKS{five}->end_line, $ENDS{EOF}, "got end line for block five"); - -is( - $BLOCKS{one}->detail, - 'one (block_one) in ' . __FILE__ . " lines $STARTS{one} -> " . ($STARTS{two} - 1), - "Got expected detail for multiline" -); - -is( - $BLOCKS{four}->detail, - 'four in ' . __FILE__ . " line $STARTS{four}", - "Got expected detail for single line" -); - -like( - $BLOCKS{foo}->detail, - qr/foo \(foo\) in \(eval \d+\) line 2 \(declared in \(eval \d+\) line 1\)/, - "Got expected detail for endless sub" -); - -done_testing; - -BEGIN { - package TheTestPackage; - - sub build_block { - my $name = shift; - my $code = pop; - my %params = @_; - my @caller = caller; - - $main::BLOCKS{$name} = Test::Stream::Block->new_from_pairs( - name => $name, - params => \%params, - coderef => $code, - caller => \@caller, - ); - } - - build_block five => \&block_five; - - BEGIN {$main::STARTS{one} = __LINE__ + 1} - sub block_one { - my $x = 1; - my $y = 1; - return "one: " . $x + $y; - } - - build_block two => sub { - my $x = 1; BEGIN {$main::STARTS{two} = __LINE__ - 1} - my $y = 1; - return "three: " . $x + $y; - }; - BEGIN {$main::ENDS{two} = __LINE__ - 1} - - sub block_three { return "three: 2" } BEGIN {$main::STARTS{three} = __LINE__} - - BEGIN {$main::STARTS{four} = __LINE__ + 1} - build_block four => sub { return "four: 2" }; - - BEGIN {$main::STARTS{five} = __LINE__ + 1} - sub block_five { - my $x = 1; - my $y = 1; - return "five: " . $x + $y; - } - - build_block one => \&block_one; - build_block three => (this_is => 3, \&block_three); - - package Foo; - eval <<' EOT' || die $@; - TheTestPackage::build_block foo => \&foo; - sub foo { - 'foo' - }; - 1 - EOT -} -BEGIN {$main::ENDS{EOF} = __LINE__} diff --git a/cpan/Test-Simple/t/Test-Stream-Carp.t b/cpan/Test-Simple/t/Test-Stream-Carp.t deleted file mode 100644 index 037d23f48b..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Carp.t +++ /dev/null @@ -1,53 +0,0 @@ -use strict; -use warnings; - -# On some threaded systems this test cannot be run. -BEGIN { - require Test::Stream::Threads; - if ($INC{'Carp.pm'}) { - print "1..0 # SKIP: Carp is already loaded before we even begin.\n"; - exit 0; - } -} - -my @stack; -BEGIN { - unshift @INC => sub { - my ($ref, $filename) = @_; - return if @stack; - return unless $filename eq 'Carp.pm'; - my %seen; - my $level = 1; - while (my @call = caller($level++)) { - my ($pkg, $file, $line) = @call; - next if $seen{"$file $line"}++; - push @stack => \@call; - } - return; - }; -} - -use Test::More; - -BEGIN { - my $r = ok(!$INC{'Carp.pm'}, "Carp is not loaded when we start"); -} - -use ok 'Test::Stream::Carp', 'croak'; - -ok(!$INC{'Carp.pm'}, "Carp is not loaded"); - -if (@stack) { - my $msg = "Carp load trace:\n"; - $msg .= " $_->[1] line $_->[2]\n" for @stack; - diag $msg; -} - -my $out = eval { croak "xxx"; 1 }; -my $err = $@; -ok(!$out, "died"); -like($err, qr/xxx/, "Got carp exception"); - -ok($INC{'Carp.pm'}, "Carp is loaded now"); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Event-Diag.t b/cpan/Test-Simple/t/Test-Stream-Event-Diag.t deleted file mode 100644 index d5297d2d15..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Event-Diag.t +++ /dev/null @@ -1,26 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; -use Test::Stream::Tester qw/intercept/; - -use ok 'Test::Stream::Event::Diag'; - -my $ctx = context(-1); my $line = __LINE__; -$ctx = $ctx->snapshot; -is($ctx->line, $line, "usable context"); - -my $diag; -intercept { $diag = context()->diag('hello') }; -ok($diag, "build diag"); -isa_ok($diag, 'Test::Stream::Event::Diag'); -is($diag->message, 'hello', "message"); - -is_deeply( - [$diag->to_tap], - [[Test::Stream::Event::Diag::OUT_ERR, "# hello\n"]], - "Got tap" -); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Event-Finish.t b/cpan/Test-Simple/t/Test-Stream-Event-Finish.t deleted file mode 100644 index db396bbbf3..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Event-Finish.t +++ /dev/null @@ -1,7 +0,0 @@ -use strict; -use warnings; -use Test::More; - -use ok 'Test::Stream::Event::Finish'; - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Event-Note.t b/cpan/Test-Simple/t/Test-Stream-Event-Note.t deleted file mode 100644 index b3bd2efda2..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Event-Note.t +++ /dev/null @@ -1,19 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -use ok 'Test::Stream::Event::Note'; - -my $note = Test::Stream::Event::Note->new('fake', 'fake', 0, "hello"); - -is($note->message, 'hello', "got message"); - -is_deeply( - [$note->to_tap], - [[Test::Stream::Event::Note::OUT_STD, "# hello\n"]], - "Got handle id and message in tap", -); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Event.t b/cpan/Test-Simple/t/Test-Stream-Event.t deleted file mode 100644 index 1351059e45..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Event.t +++ /dev/null @@ -1,30 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -use ok 'Test::Stream::Event'; - -can_ok('Test::Stream::Event', qw/context created in_subtest/); - -my $ok = eval { Test::Stream::Event->new(); 1 }; -my $err = $@; -ok(!$ok, "Died"); -like($err, qr/No context provided/, "Need context"); - -{ - package My::MockEvent; - use Test::Stream::Event( - accessors => [qw/foo bar baz/], - ); -} - -can_ok('My::MockEvent', qw/foo bar baz/); -isa_ok('My::MockEvent', 'Test::Stream::Event'); - -my $one = My::MockEvent->new('fake'); - -can_ok('Test::Stream::Context', 'mockevent'); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-ExitMagic-Context.t b/cpan/Test-Simple/t/Test-Stream-ExitMagic-Context.t deleted file mode 100644 index 42e002056c..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-ExitMagic-Context.t +++ /dev/null @@ -1,8 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -use ok 'Test::Stream::ExitMagic::Context'; - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Exporter-Meta.t b/cpan/Test-Simple/t/Test-Stream-Exporter-Meta.t deleted file mode 100644 index 124fedd8f2..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Exporter-Meta.t +++ /dev/null @@ -1,9 +0,0 @@ -use strict; -use warnings; -use Test::More; - -use ok 'Test::Stream::Exporter::Meta'; - -# This is tested by the Test::Stream::Exporter tests. - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Exporter.t b/cpan/Test-Simple/t/Test-Stream-Exporter.t deleted file mode 100644 index 6d9097c233..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Exporter.t +++ /dev/null @@ -1,122 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -{ - package My::Exporter; - use Test::Stream::Exporter; - use Test::More; - - export a => sub { 'a' }; - default_export b => sub { 'b' }; - - export 'c'; - sub c { 'c' } - - default_export x => sub { 'x' }; - - our $export = "here"; - $main::export::xxx = 'here'; - - export '$export' => \$export; - - Test::Stream::Exporter->cleanup; - - is($export, 'here', "still have an \$export var"); - is($main::export::xxx, 'here', "still have an \$export::* var"); - - ok(!__PACKAGE__->can($_), "removed $_\()") for qw/export default_export exports default_exports/; -} - -My::Exporter->import( '!x' ); - -can_ok(__PACKAGE__, qw/b/); -ok(!__PACKAGE__->can($_), "did not import $_\()") for qw/a c x/; - -My::Exporter->import(qw/a c/); -can_ok(__PACKAGE__, qw/a b c/); - -ok(!__PACKAGE__->can($_), "did not import $_\()") for qw/x/; - -My::Exporter->import(); -can_ok(__PACKAGE__, qw/a b c x/); - -is(__PACKAGE__->$_(), $_, "$_() eq '$_', Function is as expected") for qw/a b c x/; - -ok(! defined $::export, "no export scalar"); -My::Exporter->import('$export'); -is($::export, 'here', "imported export scalar"); - -use Test::Stream::Exporter qw/export_meta/; -my $meta = export_meta('My::Exporter'); -isa_ok($meta, 'Test::Stream::Exporter::Meta'); -is_deeply( - [sort $meta->default], - [sort qw/b x/], - "Got default list" -); - -is_deeply( - [sort $meta->all], - [sort qw/a b c x $export/], - "Got all list" -); - -is_deeply( - $meta->exports, - { - a => __PACKAGE__->can('a') || undef, - b => __PACKAGE__->can('b') || undef, - c => __PACKAGE__->can('c') || undef, - x => __PACKAGE__->can('x') || undef, - - '$export' => \$My::Exporter::export, - }, - "Exports are what we expect" -); - -# Make sure export_to_level us supported - -BEGIN { - package A; - - use Test::Stream::Exporter qw/import export_to_level exports/; - exports qw/foo/; - - sub foo { 'foo' } - - ############### - package B; - - sub do_it { - my $class = shift; - my ($num) = @_; - $num ||= 1; - A->export_to_level($num, $class, 'foo'); - } - - ############## - package C; - - sub do_it { - B->do_it(2); - } -} - -{ - package m1; - - BEGIN { B->do_it } -} - -{ - package m2; - - BEGIN{ C->do_it }; -} - -can_ok('m1', 'foo'); -can_ok('m2', 'foo'); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-ForceExit.t b/cpan/Test-Simple/t/Test-Stream-ForceExit.t deleted file mode 100644 index 8596494fed..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-ForceExit.t +++ /dev/null @@ -1,69 +0,0 @@ -use Test::Stream::ForceExit; -use strict; -use warnings; - -use Test::CanFork; - -use Test::Stream qw/enable_fork/; -use Test::More; -use Test::Stream::ForceExit; - -my ($read, $write); -pipe($read, $write) || die "Failed to create a pipe."; - -my $pid = fork(); -unless ($pid) { - die "Failed to fork" unless defined $pid; - close($read); - $SIG{__WARN__} = sub { print $write @_ }; - - { - my $force_exit = Test::Stream::ForceExit->new; - note "In Child"; - } - - print $write "Did not exit!"; - - ok(0, "Failed to exit"); - exit 0; -} - -close($write); -waitpid($pid, 0); -my $error = $?; -ok($error, "Got an error"); -my $msg = join("", <$read>); -is($msg, <new; - note "In Child $$"; - $force_exit->done(1); - } - - print $write "Did not exit!\n"; - - exit 0; -} - -close($write); -waitpid($pid, 0); -$error = $?; -ok(!$error, "no error"); -$msg = join("", <$read>); -is($msg, <open_handles; -ok($out && $err, "got 2 handles"); -ok(close($out), "Close stdout"); -ok(close($err), "Close stderr"); - -my $one = Test::Stream::IOSets->new; -isa_ok($one, 'Test::Stream::IOSets'); -mostly_like( - $one, - { ':legacy' => [], ':utf8' => undef }, - "Legacy encoding is set", -); - -ok($one->init_encoding('utf8'), "init utf8"); - -mostly_like( - $one, - { ':legacy' => [], ':utf8' => [] }, - "utf8 encoding is set", -); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Meta.t b/cpan/Test-Simple/t/Test-Stream-Meta.t deleted file mode 100644 index 8417b13aff..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Meta.t +++ /dev/null @@ -1,16 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -use ok 'Test::Stream::Meta'; - -my $meta = init_tester('Some::Package'); -ok($meta, "got meta"); -isa_ok($meta, 'Test::Stream::Meta'); -can_ok($meta, qw/package encoding modern todo stream/); - -is(is_tester('Some::Package'), $meta, "remember the meta"); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-PackageUtil.t b/cpan/Test-Simple/t/Test-Stream-PackageUtil.t deleted file mode 100644 index 76d80d87ed..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-PackageUtil.t +++ /dev/null @@ -1,38 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -use ok 'Test::Stream::PackageUtil'; - -can_ok(__PACKAGE__, qw/package_sym package_purge_sym/); - -my $ok = package_sym(__PACKAGE__, CODE => 'ok'); -is($ok, \&ok, "package sym gave us the code symbol"); - -my $todo = package_sym(__PACKAGE__, SCALAR => 'TODO'); -is($todo, \$TODO, "got the TODO scalar"); - -our $foo = 'foo'; -our @foo = ('f', 'o', 'o'); -our %foo = (f => 'oo'); -sub foo { 'foo' }; - -is(foo(), 'foo', "foo() is defined"); -is($foo, 'foo', '$foo is defined'); -is_deeply(\@foo, [ 'f', 'o', 'o' ], '@foo is defined'); -is_deeply(\%foo, { f => 'oo' }, '%foo is defined'); - -package_purge_sym(__PACKAGE__, CODE => 'foo'); - -is($foo, 'foo', '$foo is still defined'); -is_deeply(\@foo, [ 'f', 'o', 'o' ], '@foo is still defined'); -is_deeply(\%foo, { f => 'oo' }, '%foo is still defined'); -my $r = eval { __PACKAGE__->foo() }; -my $e = $@; -ok(!$r, "Failed to call foo()"); -like($e, qr/Can't locate object method "foo" via package "main"/, "foo() is not defined anymore"); -ok(!__PACKAGE__->can('foo'), "can() no longer thinks we can do foo()"); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Tester-Grab.t b/cpan/Test-Simple/t/Test-Stream-Tester-Grab.t deleted file mode 100644 index 505980790a..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Tester-Grab.t +++ /dev/null @@ -1,11 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -use ok 'Test::Stream::Tester::Grab'; - -# The tests for this can be found in t/Test-Tester2.t which is the only context -# that makes sense. - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Tester.t b/cpan/Test-Simple/t/Test-Stream-Tester.t deleted file mode 100644 index 2c4f11ba3a..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Tester.t +++ /dev/null @@ -1,140 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -use ok 'Test::Stream::Tester'; - -can_ok( __PACKAGE__, 'intercept', 'events_are' ); - -my $events = intercept { - ok(1, "Woo!"); - ok(0, "Boo!"); -}; - -isa_ok($events->[0], 'Test::Stream::Event::Ok'); -is($events->[0]->bool, 1, "Got one success"); -is($events->[0]->name, "Woo!", "Got test name"); - -isa_ok($events->[1], 'Test::Stream::Event::Ok'); -is($events->[1]->bool, 0, "Got one fail"); -is($events->[1]->name, "Boo!", "Got test name"); - -$events = undef; -my $grab = grab(); -my $got = $grab ? 1 : 0; -ok(1, "Intercepted!"); -ok(0, "Also Intercepted!"); -$events = $grab->finish; -ok($got, "Delayed test that we did in fact get a grab object"); -is($grab, undef, "Poof! vanished!"); -is(@$events, 2, "got 2 events (2 ok)"); -events_are( - $events, - check { - event ok => { bool => 1 }; - event ok => { - bool => 0, - diag => qr/Failed/, - }; - dir 'end'; - }, - 'intercepted via grab 1' -); - -$events = undef; -$grab = grab(); -ok(1, "Intercepted!"); -ok(0, "Also Intercepted!"); -events_are( - $grab, - check { - event ok => { bool => 1 }; - event ok => { bool => 0, diag => qr/Failed/ }; - dir 'end'; - }, - 'intercepted via grab 2' -); -ok(!$grab, "Maybe it never existed?"); - -$events = intercept { - ok(1, "Woo!"); - BAIL_OUT("Ooops"); - ok(0, "Should not see this"); -}; -is(@$events, 2, "Only got 2"); -isa_ok($events->[0], 'Test::Stream::Event::Ok'); -isa_ok($events->[1], 'Test::Stream::Event::Bail'); - -$events = intercept { - plan skip_all => 'All tests are skipped'; - - ok(1, "Woo!"); - BAIL_OUT("Ooops"); - ok(0, "Should not see this"); -}; -is(@$events, 1, "Only got 1"); -isa_ok($events->[0], 'Test::Stream::Event::Plan'); - -my $file = __FILE__; -my $line1; -my $line2; -events_are( - intercept { - events_are( - intercept { ok(1, "foo"); $line1 = __LINE__ }, - check { - $line2 = __LINE__ + 1; - event ok => {bool => 0}; - dir 'end'; - }, - 'Lets name this test!', - ); - }, - - check { - event ok => { - bool => 0, - diag => [ - qr{Failed test 'Lets name this test!'.*at (\./)?\Q$0\E line}s, - qr{ Event: 'ok' from \Q$0\E line $line1}s, - qr{ Check: 'ok' from \Q$0\E line $line2}s, - qr{ \$got->\{bool\} = '1'}, - qr{ \$exp->\{bool\} = '0'}, - ], - }; - - dir 'end'; - }, - 'Failure diag checking', -); - -my $line3; -events_are( - intercept { - events_are( - intercept { ok(1, "foo"); ok(1, "bar"); $line3 = __LINE__ }, - check { - event ok => {bool => 1}; - dir 'end' - }, - "Should Fail" - ); - }, - - check { - event ok => { - bool => 0, - diag => [ - qr/Failed test 'Should Fail'/, - qr/Expected end of events, got 'ok' from \Q$0\E line $line3/, - ], - }; - }, - - end => 'skipping a diag', -); - - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Toolset.t b/cpan/Test-Simple/t/Test-Stream-Toolset.t deleted file mode 100644 index 432af90984..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Toolset.t +++ /dev/null @@ -1,11 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -use ok 'Test::Stream::Toolset'; - -can_ok(__PACKAGE__, qw/is_tester init_tester context/); - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Stream-Util.t b/cpan/Test-Simple/t/Test-Stream-Util.t deleted file mode 100644 index fa9ff54aec..0000000000 --- a/cpan/Test-Simple/t/Test-Stream-Util.t +++ /dev/null @@ -1,45 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; -use Scalar::Util qw/dualvar/; - -use ok 'Test::Stream::Util', qw{ - try protect spoof is_regex is_dualvar -}; - -can_ok(__PACKAGE__, qw{ - try protect spoof is_regex is_dualvar -}); - -my $x = dualvar( 100, 'one-hundred' ); -ok(is_dualvar($x), "Got dual var"); -$x = 1; -ok(!is_dualvar($x), "Not dual var"); - -$! = 100; - -my $ok = eval { protect { die "xxx" }; 1 }; -ok(!$ok, "protect did not capture exception"); -like($@, qr/xxx/, "expected exception"); - -cmp_ok($!, '==', 100, "\$! did not change"); -$@ = 'foo'; - -($ok, my $err) = try { die "xxx" }; -ok(!$ok, "cought exception"); -like( $err, qr/xxx/, "expected exception"); -is($@, 'foo', '$@ is saved'); -cmp_ok($!, '==', 100, "\$! did not change"); - -ok(is_regex(qr/foo bar baz/), 'qr regex'); -ok(is_regex('/xxx/'), 'slash regex'); -ok(!is_regex('xxx'), 'not a regex'); - -my ($ret, $e) = spoof ["The::Moon", "Moon.pm", 11] => "die 'xxx' . __PACKAGE__"; -ok(!$ret, "Failed eval"); -like( $e, qr/^xxxThe::Moon at Moon\.pm line 11\.?/, "Used correct package, file, and line"); - - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Tester-Capture.t b/cpan/Test-Simple/t/Test-Tester-Capture.t deleted file mode 100644 index c4a61bae37..0000000000 --- a/cpan/Test-Simple/t/Test-Tester-Capture.t +++ /dev/null @@ -1,9 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use ok 'Test::Tester::Capture'; - -# This is tested in t/Legacy/TestTester - -done_testing; diff --git a/cpan/Test-Simple/t/Test-Tester.t b/cpan/Test-Simple/t/Test-Tester.t deleted file mode 100644 index 260b228531..0000000000 --- a/cpan/Test-Simple/t/Test-Tester.t +++ /dev/null @@ -1,9 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use ok 'Test::Tester'; - -# The tests for this can be found in t/Legacy/TestTester - -done_testing; diff --git a/cpan/Test-Simple/t/Test-use-ok.t b/cpan/Test-Simple/t/Test-use-ok.t deleted file mode 100644 index b84b4a15fd..0000000000 --- a/cpan/Test-Simple/t/Test-use-ok.t +++ /dev/null @@ -1,25 +0,0 @@ -use strict; -use warnings; - -use Test::Stream; -use Test::More; - -use ok 'ok'; - -use Test::Stream::Tester; - -events_are ( - intercept { - eval "use ok 'Something::Fake'; 1" || die $@; - }, - check { - event ok => { - bool => 0, - name => 'use Something::Fake;', - diag => qr/^\s*Failed test 'use Something::Fake;'/, - }; - }, - "Basic test" -); - -done_testing; 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..62820741c2 --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_01basic.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 10; +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(qr/ok 1 - tested\n/); +ok(1,"tested"); +test_test("regexp matching"); + +test_out("not ok 1 - should fail"); +test_err("# Failed test ($0 at line 32)"); +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_out("# Failed (TODO) test ($0 at line 56)"); +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..b02b617293 --- /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(); + + # remember 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..9542d755f4 --- /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(); + + # remember 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/Tester/tbt_08subtest.t b/cpan/Test-Simple/t/Tester/tbt_08subtest.t new file mode 100644 index 0000000000..6ec508f247 --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_08subtest.t @@ -0,0 +1,16 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Test::Builder::Tester tests => 1; +use Test::More; + +subtest 'foo' => sub { + plan tests => 1; + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); +}; diff --git a/cpan/Test-Simple/t/Tester/tbt_09do.t b/cpan/Test-Simple/t/Tester/tbt_09do.t new file mode 100644 index 0000000000..a0c8b8e2e5 --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_09do.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::Builder::Tester tests => 3; +use Test::More; +use File::Basename qw(dirname); +use File::Spec qw(); + +my $file = File::Spec->join(dirname(__FILE__), 'tbt_09do_script.pl'); +my $done = do $file; +ok(defined($done), 'do succeeded') or do { + if ($@) { + diag qq( \$@ is '$@'\n); + } elsif ($!) { + diag qq( \$! is '$!'\n); + } else { + diag qq( file's last statement returned undef: $file) + } +}; diff --git a/cpan/Test-Simple/t/Tester/tbt_09do_script.pl b/cpan/Test-Simple/t/Tester/tbt_09do_script.pl new file mode 100644 index 0000000000..590a03b085 --- /dev/null +++ b/cpan/Test-Simple/t/Tester/tbt_09do_script.pl @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +isnt($0, __FILE__, 'code is not executing directly'); + +test_out("not ok 1 - one"); +test_fail(+1); +ok(0,"one"); +test_test('test_fail caught fail message inside a do'); + +1; diff --git a/cpan/Test-Simple/t/auto.t b/cpan/Test-Simple/t/auto.t new file mode 100644 index 0000000000..0010342ee9 --- /dev/null +++ b/cpan/Test-Simple/t/auto.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use lib 't'; + +use Test::Tester tests => 5; + +use SmallTest; + +use MyTest; + +{ + my ($prem, @results) = run_tests( + sub { MyTest::ok(1, "run pass")} + ); + + is_eq($results[0]->{name}, "run pass"); + is_num($results[0]->{ok}, 1); +} + +{ + my ($prem, @results) = run_tests( + sub { MyTest::ok(0, "run fail")} + ); + + is_eq($results[0]->{name}, "run fail"); + is_num($results[0]->{ok}, 0); +} + +is_eq(ref(SmallTest::getTest()), "Test::Tester::Delegate"); 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/capture.t b/cpan/Test-Simple/t/capture.t new file mode 100644 index 0000000000..f9103bd6aa --- /dev/null +++ b/cpan/Test-Simple/t/capture.t @@ -0,0 +1,32 @@ +use strict; + +use Test::Tester; + +my $Test = Test::Builder->new; +$Test->plan(tests => 3); + +my $cap; + +$cap = Test::Tester->capture; + +{ + no warnings 'redefine'; + sub Test::Tester::find_run_tests { return 0}; +} + +local $Test::Builder::Level = 0; +{ + my $cur = $cap->current_test; + $Test->is_num($cur, 0, "current test"); + + eval {$cap->current_test(2)}; + $Test->ok($@, "can't set test_num"); +} + +{ + $cap->ok(1, "a test"); + + my @res = $cap->details; + + $Test->is_num(scalar @res, 1, "res count"); +} diff --git a/cpan/Test-Simple/t/check_tests.t b/cpan/Test-Simple/t/check_tests.t new file mode 100644 index 0000000000..ec88e2d48c --- /dev/null +++ b/cpan/Test-Simple/t/check_tests.t @@ -0,0 +1,117 @@ +use strict; + +use Test::Tester; + +use Data::Dumper qw(Dumper); + +my $test = Test::Builder->new; +$test->plan(tests => 105); + +my $cap; + +$cap = Test::Tester->capture; + +my @tests = ( + [ + 'pass', + '$cap->ok(1, "pass");', + { + name => "pass", + ok => 1, + actual_ok => 1, + reason => "", + type => "", + diag => "", + depth => 0, + }, + ], + [ + 'pass diag', + '$cap->ok(1, "pass diag"); + $cap->diag("pass diag1"); + $cap->diag("pass diag2");', + { + name => "pass diag", + ok => 1, + actual_ok => 1, + reason => "", + type => "", + diag => "pass diag1\npass diag2\n", + depth => 0, + }, + ], + [ + 'pass diag no \\n', + '$cap->ok(1, "pass diag"); + $cap->diag("pass diag1"); + $cap->diag("pass diag2");', + { + name => "pass diag", + ok => 1, + actual_ok => 1, + reason => "", + type => "", + diag => "pass diag1\npass diag2", + depth => 0, + }, + ], + [ + 'fail', + '$cap->ok(0, "fail"); + $cap->diag("fail diag");', + { + name => "fail", + ok => 0, + actual_ok => 0, + reason => "", + type => "", + diag => "fail diag\n", + depth => 0, + }, + ], + [ + 'skip', + '$cap->skip("just because");', + { + name => "", + ok => 1, + actual_ok => 1, + reason => "just because", + type => "skip", + diag => "", + depth => 0, + }, + ], + [ + 'todo_skip', + '$cap->todo_skip("why not");', + { + name => "", + ok => 1, + actual_ok => 0, + reason => "why not", + type => "todo_skip", + diag => "", + depth => 0, + }, + ], +); + +my $big_code = ""; +my @big_expect; + +foreach my $test (@tests) +{ + my ($name, $code, $expect) = @$test; + + $big_code .= "$code\n"; + push(@big_expect, $expect); + + my $test_sub = eval "sub {$code}"; + + check_test($test_sub, $expect, $name); +} + +my $big_test_sub = eval "sub {$big_code}"; + +check_tests($big_test_sub, \@big_expect, "run all"); 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..c9b9f1bf65 --- /dev/null +++ b/cpan/Test-Simple/t/cmp_ok.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use lib 't/lib'; + +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, $error) = @_; + + my %expect; + if( $error ) { + $expect{ok} = 0; + $expect{error} = $error; + } + else { + $expect{ok} = eval "\$left $cmp \$right"; + $expect{error} = $@; + $expect{error} =~ s/ at .*\n?//; + } + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + my $ok; + eval { $ok = cmp_ok($left, $cmp, $right, "cmp_ok"); }; + + $TB->is_num(!!$ok, !!$expect{ok}, " right return"); + + my $diag = $err->read; + + if ($@) { + $diag = $@; + $diag =~ s/ at .*\n?//; + } + + 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], + + [1, "=", 0, "= is not a valid comparison operator in cmp_ok()"], + [1, "+=", 0, "+= is not a valid comparison operator in cmp_ok()"], +); + +plan tests => scalar @Tests; +$TB->plan(tests => @Tests * 2); + +for my $test (@Tests) { + try_cmp_ok(@$test); +} diff --git a/cpan/Test-Simple/t/dependents.t b/cpan/Test-Simple/t/dependents.t new file mode 100644 index 0000000000..90e8938ebe --- /dev/null +++ b/cpan/Test-Simple/t/dependents.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +# Test important dependant modules so we don't accidentally half of CPAN. + +use strict; +use warnings; + +use Test::More; + +BEGIN { + plan skip_all => "Dependents only tested when releasing" unless $ENV{PERL_RELEASING}; +} + +require File::Spec; +use CPAN; + +CPAN::HandleConfig->load; +$CPAN::Config->{test_report} = 0; + +# Module which depend on Test::More to test +my @Modules = qw( + Test::Most + Test::Warn + Test::Exception + Test::Class + Test::Deep + Test::Differences + Test::NoWarnings +); + +# Modules which are known to be broken +my %Broken = map { $_ => 1 } qw( +); + +TODO: for my $name (@ARGV ? @ARGV : @Modules) { + local $TODO = "$name known to be broken" if $Broken{$name}; + + local $ENV{PERL5LIB} = "$ENV{PERL5LIB}:" . File::Spec->rel2abs("blib/lib"); + my $module = CPAN::Shell->expand("Module", $name); + $module->test; + ok( !$module->distribution->{make_test}->failed, $name ); +} + +done_testing(); diff --git a/cpan/Test-Simple/t/depth.t b/cpan/Test-Simple/t/depth.t new file mode 100644 index 0000000000..acbf07f2b1 --- /dev/null +++ b/cpan/Test-Simple/t/depth.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use lib 't'; + +use Test::Tester; + +use MyTest; + +my $test = Test::Builder->new; +$test->plan(tests => 2); + +sub deeper +{ + MyTest::ok(1); +} + +{ + + my @results = run_tests( + sub { + MyTest::ok(1); + deeper(); + } + ); + + local $Test::Builder::Level = 0; + $test->is_num($results[1]->{depth}, 1, "depth 1"); + $test->is_num($results[2]->{depth}, 2, "deeper"); +} + 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, <is_eq($err->read, <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..cf9f907438 --- /dev/null +++ b/cpan/Test-Simple/t/dont_overwrite_die_handler.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl -w +use Config; # To prevent conflict with some strawberry-portable versions + +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..e32e986314 --- /dev/null +++ b/cpan/Test-Simple/t/exit.t @@ -0,0 +1,117 @@ +#!/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"}; +} else { + $Perl = qq("$Perl"); # protect from shell if spaces +} + +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, + 'one_fail_without_plan.plx' => 1, + 'missing_done_testing.plx' => 254, + ); + +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..55a0007d49 --- /dev/null +++ b/cpan/Test-Simple/t/extra.t @@ -0,0 +1,60 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::Builder; +use Test::Builder::NoOutput; +use Test::Simple; + +my $TB = Test::Builder->new; +my $test = Test::Builder::NoOutput->create; +$test->plan( tests => 3 ); + +local $ENV{HARNESS_ACTIVE} = 0; + +$test->ok(1, 'Foo'); +$TB->is_eq($test->read(), <ok(0, 'Bar'); +$TB->is_eq($test->read(), <ok(1, 'Yar'); +$test->ok(1, 'Car'); +$TB->is_eq($test->read(), <ok(0, 'Sar'); +$TB->is_eq($test->read(), <_ending(); +$TB->is_eq($test->read(), <done_testing(5); 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, <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, <like($err->read, qr/^$err_re$/, 'failing errors'); +} + +{ + # line 62 + like("foo", "not a regex"); + $TB->is_eq($out->read, <is_eq($err->read, <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..5c35d49bd3 --- /dev/null +++ b/cpan/Test-Simple/t/fail-more.t @@ -0,0 +1,521 @@ +#!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 => 80); + +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 = 38; +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( <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( <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( <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( <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( <new\\(\\) died +OUT +# Failed test 'undef->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( <new\\(\\) died +OUT +# Failed test 'Does::Not::Exist->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( <is_eq( $out->read, <is_eq( $err->read, <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'), <is_eq($tb->read('err'), <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'), <is_eq($tb->read('err'), <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( < 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..26036fb960 --- /dev/null +++ b/cpan/Test-Simple/t/is_deeply_fail.t @@ -0,0 +1,421 @@ +#!/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 => 100); + +# Utility testing functions. +sub ok ($;$) { + return $TB->ok(@_); +} + +sub is ($$;$) { + my($thing, $that, $name) = @_; + + my $ok = $TB->is_eq($$thing, $that, $name); + + $$thing = ''; + + return $ok; +} + +sub like ($$;$) { + my($thing, $regex, $name) = @_; + $regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s; + + my $ok = $TB->like($$thing, $regex, $name); + + $$thing = ''; + + 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, < 42 }, { this => 43 }, 'hashes with different values'); +is( $out, "not ok 3 - hashes with different values\n", + 'hashes with different values' ); +is( $err, <{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, <{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, <[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, <[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, <{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, < \$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, <{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, <[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, <[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, <[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, < 0}, {x => ''}, "{x => 0} != {x => ''}" ); + is( $out, "not ok 39 - {x => 0} != {x => ''}\n" ); + ok !is_deeply( {x => 0}, {x => undef}, "{x => 0} != {x => undef}" ); + is( $out, "not ok 40 - {x => 0} != {x => undef}\n" ); + ok !is_deeply( {x => ''}, {x => undef}, "{x => ''} != {x => undef}" ); + is( $out, "not ok 41 - {x => ''} != {x => undef}\n" ); +} 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/MyTest.pm b/cpan/Test-Simple/t/lib/MyTest.pm deleted file mode 100644 index e8ad8a3e53..0000000000 --- a/cpan/Test-Simple/t/lib/MyTest.pm +++ /dev/null @@ -1,15 +0,0 @@ -use strict; -use warnings; - -package MyTest; - -use Test::Builder; - -my $Test = Test::Builder->new; - -sub ok -{ - $Test->ok(@_); -} - -1; diff --git a/cpan/Test-Simple/t/lib/SmallTest.pm b/cpan/Test-Simple/t/lib/SmallTest.pm deleted file mode 100644 index c2a875855e..0000000000 --- a/cpan/Test-Simple/t/lib/SmallTest.pm +++ /dev/null @@ -1,35 +0,0 @@ -use strict; -use warnings; - -package SmallTest; - -require Exporter; - -use vars qw( @ISA @EXPORT ); -@ISA = qw( Exporter ); -@EXPORT = qw( ok is_eq is_num ); - -use Test::Builder; - -my $Test = Test::Builder->new; - -sub ok -{ - $Test->ok(@_); -} - -sub is_eq -{ - $Test->is_eq(@_); -} - -sub is_num -{ - $Test->is_num(@_); -} - -sub getTest -{ - return $Test; -} -1; diff --git a/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm index 7c6bb69b86..bbdf73268f 100644 --- a/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm +++ b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm @@ -26,7 +26,7 @@ Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing This is a subclass of Test::Builder which traps all its output. It is mostly useful for testing Test::Builder. -=head2 read +=head3 read my $all_output = $tb->read; my $output = $tb->read($stream); 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, < 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, <is_eq($err->read, <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, < "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/run_test.t b/cpan/Test-Simple/t/run_test.t new file mode 100644 index 0000000000..8288f19ab8 --- /dev/null +++ b/cpan/Test-Simple/t/run_test.t @@ -0,0 +1,145 @@ +use strict; + +use Test::Tester; + +use Data::Dumper qw(Dumper); + +my $test = Test::Builder->new; +$test->plan(tests => 54); + +my $cap; + +{ + $cap = Test::Tester->capture; + my ($prem, @results) = run_tests( + sub {$cap->ok(1, "run pass")} + ); + + local $Test::Builder::Level = 0; + + $test->is_eq($prem, "", "run pass no prem"); + $test->is_num(scalar (@results), 1, "run pass result count"); + + my $res = $results[0]; + + $test->is_eq($res->{name}, "run pass", "run pass name"); + $test->is_eq($res->{ok}, 1, "run pass ok"); + $test->is_eq($res->{actual_ok}, 1, "run pass actual_ok"); + $test->is_eq($res->{reason}, "", "run pass reason"); + $test->is_eq($res->{type}, "", "run pass type"); + $test->is_eq($res->{diag}, "", "run pass diag"); + $test->is_num($res->{depth}, 0, "run pass depth"); +} + +{ + my ($prem, @results) = run_tests( + sub {$cap->ok(0, "run fail")} + ); + + local $Test::Builder::Level = 0; + + $test->is_eq($prem, "", "run fail no prem"); + $test->is_num(scalar (@results), 1, "run fail result count"); + + my $res = $results[0]; + + $test->is_eq($res->{name}, "run fail", "run fail name"); + $test->is_eq($res->{actual_ok}, 0, "run fail actual_ok"); + $test->is_eq($res->{ok}, 0, "run fail ok"); + $test->is_eq($res->{reason}, "", "run fail reason"); + $test->is_eq($res->{type}, "", "run fail type"); + $test->is_eq($res->{diag}, "", "run fail diag"); + $test->is_num($res->{depth}, 0, "run fail depth"); +} + +{ + my ($prem, @results) = run_tests( + sub {$cap->skip("just because")} + ); + + local $Test::Builder::Level = 0; + + $test->is_eq($prem, "", "skip no prem"); + $test->is_num(scalar (@results), 1, "skip result count"); + + my $res = $results[0]; + + $test->is_eq($res->{name}, "", "skip name"); + $test->is_eq($res->{actual_ok}, 1, "skip actual_ok"); + $test->is_eq($res->{ok}, 1, "skip ok"); + $test->is_eq($res->{reason}, "just because", "skip reason"); + $test->is_eq($res->{type}, "skip", "skip type"); + $test->is_eq($res->{diag}, "", "skip diag"); + $test->is_num($res->{depth}, 0, "skip depth"); +} + +{ + my ($prem, @results) = run_tests( + sub {$cap->todo_skip("just because")} + ); + + local $Test::Builder::Level = 0; + + $test->is_eq($prem, "", "todo_skip no prem"); + $test->is_num(scalar (@results), 1, "todo_skip result count"); + + my $res = $results[0]; + + $test->is_eq($res->{name}, "", "todo_skip name"); + $test->is_eq($res->{actual_ok}, 0, "todo_skip actual_ok"); + $test->is_eq($res->{ok}, 1, "todo_skip ok"); + $test->is_eq($res->{reason}, "just because", "todo_skip reason"); + $test->is_eq($res->{type}, "todo_skip", "todo_skip type"); + $test->is_eq($res->{diag}, "", "todo_skip diag"); + $test->is_num($res->{depth}, 0, "todo_skip depth"); +} + +{ + my ($prem, @results) = run_tests( + sub {$cap->diag("run diag")} + ); + + local $Test::Builder::Level = 0; + + $test->is_eq($prem, "run diag\n", "run diag prem"); + $test->is_num(scalar (@results), 0, "run diag result count"); +} + +{ + my ($prem, @results) = run_tests( + sub { + $cap->ok(1, "multi pass"); + $cap->diag("multi pass diag1"); + $cap->diag("multi pass diag2"); + $cap->ok(0, "multi fail"); + $cap->diag("multi fail diag"); + } + ); + + local $Test::Builder::Level = 0; + + $test->is_eq($prem, "", "run multi no prem"); + $test->is_num(scalar (@results), 2, "run multi result count"); + + my $res_pass = $results[0]; + + $test->is_eq($res_pass->{name}, "multi pass", "run multi pass name"); + $test->is_eq($res_pass->{actual_ok}, 1, "run multi pass actual_ok"); + $test->is_eq($res_pass->{ok}, 1, "run multi pass ok"); + $test->is_eq($res_pass->{reason}, "", "run multi pass reason"); + $test->is_eq($res_pass->{type}, "", "run multi pass type"); + $test->is_eq($res_pass->{diag}, "multi pass diag1\nmulti pass diag2\n", + "run multi pass diag"); + $test->is_num($res_pass->{depth}, 0, "run multi pass depth"); + + my $res_fail = $results[1]; + + $test->is_eq($res_fail->{name}, "multi fail", "run multi fail name"); + $test->is_eq($res_pass->{actual_ok}, 1, "run multi fail actual_ok"); + $test->is_eq($res_fail->{ok}, 0, "run multi fail ok"); + $test->is_eq($res_pass->{reason}, "", "run multi fail reason"); + $test->is_eq($res_pass->{type}, "", "run multi fail type"); + $test->is_eq($res_fail->{diag}, "multi fail diag\n", "run multi fail diag"); + $test->is_num($res_pass->{depth}, 0, "run multi fail depth"); +} + 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/subtest/args.t b/cpan/Test-Simple/t/subtest/args.t new file mode 100644 index 0000000000..8ae26baa93 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/args.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w + +use strict; +use Test::Builder; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } +} +use Test::Builder::NoOutput; + +my $tb = Test::Builder->new; + +$tb->ok( !eval { $tb->subtest() } ); +$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); + +$tb->ok( !eval { $tb->subtest("foo") } ); +$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); + +$tb->subtest('Arg passing', sub { + my $foo = shift; + my $child = Test::Builder->new; + $child->is_eq($foo, 'foo'); + $child->done_testing; + $child->finalize; +}, 'foo'); + +$tb->done_testing(); diff --git a/cpan/Test-Simple/t/subtest/bail_out.t b/cpan/Test-Simple/t/subtest/bail_out.t new file mode 100644 index 0000000000..70dc9ac56f --- /dev/null +++ b/cpan/Test-Simple/t/subtest/bail_out.t @@ -0,0 +1,59 @@ +#!/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 => 2); + +plan tests => 4; + +ok 'foo'; +subtest 'bar' => sub { + plan tests => 3; + ok 'sub_foo'; + subtest 'sub_bar' => sub { + plan tests => 3; + ok 'sub_sub_foo'; + ok 'sub_sub_bar'; + BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); + ok 'sub_sub_baz'; + }; + ok 'sub_baz'; +}; + +$Test->is_eq( $output, <<'OUT' ); +1..4 +ok 1 + # Subtest: bar + 1..3 + ok 1 + # Subtest: sub_bar + 1..3 + ok 1 + ok 2 +Bail out! ROCKS FALL! EVERYONE DIES! +OUT + +$Test->is_eq( $Exit_Code, 255 ); diff --git a/cpan/Test-Simple/t/subtest/basic.t b/cpan/Test-Simple/t/subtest/basic.t new file mode 100644 index 0000000000..93780a9da2 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/basic.t @@ -0,0 +1,214 @@ +#!/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 => 19; + +# Formatting may change if we're running under Test::Harness. +$ENV{HARNESS_ACTIVE} = 0; + +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->plan( tests => 7 ); + for( 1 .. 3 ) { + $tb->ok( $_, "We're on $_" ); + $tb->diag("We ran $_"); + } + { + my $indented = $tb->child; + $indented->plan('no_plan'); + $indented->ok( 1, "We're on 1" ); + $indented->ok( 1, "We're on 2" ); + $indented->ok( 1, "We're on 3" ); + $indented->finalize; + } + for( 7, 8, 9 ) { + $tb->ok( $_, "We're on $_" ); + } + + is $tb->read, <<"END", 'Output should nest properly'; +1..7 +ok 1 - We're on 1 +# We ran 1 +ok 2 - We're on 2 +# We ran 2 +ok 3 - We're on 3 +# We ran 3 + ok 1 - We're on 1 + ok 2 - We're on 2 + ok 3 - We're on 3 + 1..3 +ok 4 - Child of $0 +ok 5 - We're on 7 +ok 6 - We're on 8 +ok 7 - We're on 9 +END +} +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->plan('no_plan'); + for( 1 .. 1 ) { + $tb->ok( $_, "We're on $_" ); + $tb->diag("We ran $_"); + } + { + my $indented = $tb->child; + $indented->plan('no_plan'); + $indented->ok( 1, "We're on 1" ); + { + my $indented2 = $indented->child('with name'); + $indented2->plan( tests => 2 ); + $indented2->ok( 1, "We're on 2.1" ); + $indented2->ok( 1, "We're on 2.1" ); + $indented2->finalize; + } + $indented->ok( 1, 'after child' ); + $indented->finalize; + } + for(7) { + $tb->ok( $_, "We're on $_" ); + } + + $tb->_ending; + is $tb->read, <<"END", 'We should allow arbitrary nesting'; +ok 1 - We're on 1 +# We ran 1 + ok 1 - We're on 1 + 1..2 + ok 1 - We're on 2.1 + ok 2 - We're on 2.1 + ok 2 - with name + ok 3 - after child + 1..3 +ok 2 - Child of $0 +ok 3 - We're on 7 +1..3 +END +} + +{ +#line 108 + my $tb = Test::Builder::NoOutput->create; + + { + my $child = $tb->child('expected to fail'); + $child->plan( tests => 3 ); + $child->ok(1); + $child->ok(0); + $child->ok(3); + $child->finalize; + } + + { + my $child = $tb->child('expected to pass'); + $child->plan( tests => 3 ); + $child->ok(1); + $child->ok(2); + $child->ok(3); + $child->finalize; + } + is $tb->read, <<"END", 'Previous child failures should not force subsequent failures'; + 1..3 + ok 1 + not ok 2 + # Failed test at $0 line 114. + ok 3 + # Looks like you failed 1 test of 3. +not ok 1 - expected to fail +# Failed test 'expected to fail' +# at $0 line 116. + 1..3 + ok 1 + ok 2 + ok 3 +ok 2 - expected to pass +END +} +{ + my $tb = Test::Builder::NoOutput->create; + my $child = $tb->child('one'); + is $child->{$_}, $tb->{$_}, "The child should copy the ($_) filehandle" + foreach qw{Out_FH Todo_FH Fail_FH}; + $child->finalize; +} +{ + my $tb = Test::Builder::NoOutput->create; + my $child = $tb->child('one'); + can_ok $child, 'parent'; + is $child->parent, $tb, '... and it should return the parent of the child'; + ok !defined $tb->parent, '... but top level builders should not have parents'; + + can_ok $tb, 'name'; + is $tb->name, $0, 'The top level name should be $0'; + is $child->name, 'one', '... but child names should be whatever we set them to'; + $child->finalize; + $child = $tb->child; + is $child->name, 'Child of '.$tb->name, '... or at least have a sensible default'; + $child->finalize; +} +# Skip all subtests +{ + my $tb = Test::Builder::NoOutput->create; + + { + my $child = $tb->child('skippy says he loves you'); + eval { $child->plan( skip_all => 'cuz I said so' ) }; + ok my $error = $@, 'A child which does a "skip_all" should throw an exception'; + isa_ok $error, 'Test::Builder::Exception', '... and the exception it throws'; + } + subtest 'skip all', sub { + plan skip_all => 'subtest with skip_all'; + ok 0, 'This should never be run'; + }; + is +Test::Builder->new->{Test_Results}[-1]{type}, 'skip', + 'Subtests which "skip_all" are reported as skipped tests'; +} + +# to do tests +{ +#line 204 + my $tb = Test::Builder::NoOutput->create; + $tb->plan( tests => 1 ); + my $child = $tb->child; + $child->plan( tests => 1 ); + $child->todo_start( 'message' ); + $child->ok( 0 ); + $child->todo_end; + $child->finalize; + $tb->_ending; + is $tb->read, <<"END", 'TODO tests should not make the parent test fail'; +1..1 + 1..1 + not ok 1 # TODO message + # Failed (TODO) test at $0 line 209. +ok 1 - Child of $0 +END +} +{ + my $tb = Test::Builder::NoOutput->create; + $tb->plan( tests => 1 ); + my $child = $tb->child; + $child->finalize; + $tb->_ending; + my $expected = <<"END"; +1..1 +not ok 1 - No tests run for subtest "Child of $0" +END + like $tb->read, qr/\Q$expected/, + 'Not running subtests should make the parent test fail'; +} diff --git a/cpan/Test-Simple/t/subtest/die.t b/cpan/Test-Simple/t/subtest/die.t new file mode 100644 index 0000000000..3d53abf6cc --- /dev/null +++ b/cpan/Test-Simple/t/subtest/die.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +# What happens when a subtest dies? + +use lib 't/lib'; + +use strict; +use Test::Builder; +use Test::Builder::NoOutput; + +my $Test = Test::Builder->new; + +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->ok(1); + + $Test->ok( !eval { + $tb->subtest("death" => sub { + die "Death in the subtest"; + }); + 1; + }); + $Test->like( $@, qr/^Death in the subtest at \Q$0\E line /); + + $Test->ok( !$tb->parent, "the parent object is restored after a die" ); +} + + +$Test->done_testing(); diff --git a/cpan/Test-Simple/t/subtest/do.t b/cpan/Test-Simple/t/subtest/do.t new file mode 100644 index 0000000000..40b950184e --- /dev/null +++ b/cpan/Test-Simple/t/subtest/do.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl -w + +# Test the idiom of running another test file as a subtest. + +use strict; +use Test::More; + +pass("First"); + +my $file = "t/subtest/for_do_t.test"; +ok -e $file, "subtest test file exists"; + +subtest $file => sub { do $file }; + +pass("Last"); + +done_testing(4); diff --git a/cpan/Test-Simple/t/subtest/exceptions.t b/cpan/Test-Simple/t/subtest/exceptions.t new file mode 100644 index 0000000000..92d65b648a --- /dev/null +++ b/cpan/Test-Simple/t/subtest/exceptions.t @@ -0,0 +1,63 @@ +#!/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 => 7; + +{ + my $tb = Test::Builder::NoOutput->create; + $tb->child('one'); + eval { $tb->child('two') }; + my $error = $@; + like $error, qr/\QYou already have a child named (one) running/, + 'Trying to create a child with another one active should fail'; +} +{ + my $tb = Test::Builder::NoOutput->create; + my $child = $tb->child('one'); + ok my $child2 = $child->child('two'), 'Trying to create nested children should succeed'; + eval { $child->finalize }; + my $error = $@; + like $error, qr/\QCan't call finalize() with child (two) active/, + '... but trying to finalize() a child with open children should fail'; +} +{ + my $tb = Test::Builder::NoOutput->create; + my $child = $tb->child('one'); + undef $child; + like $tb->read, qr/\QChild (one) exited without calling finalize()/, + 'Failing to call finalize should issue an appropriate diagnostic'; + ok !$tb->is_passing, '... and should cause the test suite to fail'; +} +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->plan( tests => 7 ); + for( 1 .. 3 ) { + $tb->ok( $_, "We're on $_" ); + $tb->diag("We ran $_"); + } + { + my $indented = $tb->child; + $indented->plan('no_plan'); + $indented->ok( 1, "We're on 1" ); + eval { $tb->ok( 1, 'This should throw an exception' ) }; + $indented->finalize; + } + + my $error = $@; + like $error, qr/\QCannot run test (This should throw an exception) with active children/, + 'Running a test with active children should fail'; + ok !$tb->is_passing, '... and should cause the test suite to fail'; +} diff --git a/cpan/Test-Simple/t/subtest/for_do_t.test b/cpan/Test-Simple/t/subtest/for_do_t.test new file mode 100644 index 0000000000..413923bceb --- /dev/null +++ b/cpan/Test-Simple/t/subtest/for_do_t.test @@ -0,0 +1,9 @@ +# Test used by t/subtest/do.t + +use Test::More; + +pass("First"); +pass("Second"); +pass("Third"); + +done_testing(3); diff --git a/cpan/Test-Simple/t/subtest/fork.t b/cpan/Test-Simple/t/subtest/fork.t new file mode 100644 index 0000000000..e072a4813e --- /dev/null +++ b/cpan/Test-Simple/t/subtest/fork.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Config; +use IO::Pipe; +use Test::Builder; +use Test::More; + +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; +} + +subtest 'fork within subtest' => sub { + plan tests => 2; + + my $pipe = IO::Pipe->new; + my $pid = fork; + defined $pid or plan skip_all => "Fork not working"; + + if ($pid) { + $pipe->reader; + my $child_output = do { local $/ ; <$pipe> }; + waitpid $pid, 0; + + is $?, 0, 'child exit status'; + like $child_output, qr/^[\s#]+Child Done\s*\z/, 'child output'; + } + else { + $pipe->writer; + + # Force all T::B output into the pipe, for the parent + # builder as well as the current subtest builder. + no warnings 'redefine'; + *Test::Builder::output = sub { $pipe }; + *Test::Builder::failure_output = sub { $pipe }; + *Test::Builder::todo_output = sub { $pipe }; + + diag 'Child Done'; + exit 0; + } +}; + diff --git a/cpan/Test-Simple/t/subtest/implicit_done.t b/cpan/Test-Simple/t/subtest/implicit_done.t new file mode 100644 index 0000000000..0963e72c59 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/implicit_done.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl -w + +# A subtest without a plan implicitly calls "done_testing" + +use strict; +use Test::More; + +pass "Before"; + +subtest 'basic' => sub { + pass "Inside sub test"; +}; + +subtest 'with done' => sub { + pass 'This has done_testing'; + done_testing; +}; + +subtest 'with plan' => sub { + plan tests => 1; + pass 'I have a plan, Batman!'; +}; + +subtest 'skipping' => sub { + plan skip_all => 'Skipping'; + fail 'Shouldnt see me!'; +}; + +pass "After"; + +done_testing; diff --git a/cpan/Test-Simple/t/subtest/line_numbers.t b/cpan/Test-Simple/t/subtest/line_numbers.t new file mode 100644 index 0000000000..7a20a60ae6 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/line_numbers.t @@ -0,0 +1,130 @@ +#!/usr/bin/perl -w + +# Test Test::More::subtest(), focusing on correct line numbers in +# failed test diagnostics. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::More tests => 5; +use Test::Builder; +use Test::Builder::Tester; + +# Formatting may change if we're running under Test::Harness. +$ENV{HARNESS_ACTIVE} = 0; + +our %line; + +{ + test_out(" # Subtest: namehere"); + test_out(" 1..3"); + test_out(" ok 1"); + test_out(" not ok 2"); + test_err(" # Failed test at $0 line $line{innerfail1}."); + test_out(" ok 3"); + test_err(" # Looks like you failed 1 test of 3."); + test_out("not ok 1 - namehere"); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line $line{outerfail1}."); + + subtest namehere => sub { + plan tests => 3; + ok 1; + ok 0; BEGIN{ $line{innerfail1} = __LINE__ } + ok 1; + }; BEGIN{ $line{outerfail1} = __LINE__ } + + test_test("un-named inner tests"); +} +{ + test_out(" # Subtest: namehere"); + test_out(" 1..3"); + test_out(" ok 1 - first is good"); + test_out(" not ok 2 - second is bad"); + test_err(" # Failed test 'second is bad'"); + test_err(" # at $0 line $line{innerfail2}."); + test_out(" ok 3 - third is good"); + test_err(" # Looks like you failed 1 test of 3."); + test_out("not ok 1 - namehere"); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line $line{outerfail2}."); + + subtest namehere => sub { + plan tests => 3; + ok 1, "first is good"; + ok 0, "second is bad"; BEGIN{ $line{innerfail2} = __LINE__ } + ok 1, "third is good"; + }; BEGIN{ $line{outerfail2} = __LINE__ } + + test_test("named inner tests"); +} + +sub run_the_subtest { + subtest namehere => sub { + plan tests => 3; + ok 1, "first is good"; + ok 0, "second is bad"; BEGIN{ $line{innerfail3} = __LINE__ } + ok 1, "third is good"; + }; BEGIN{ $line{outerfail3} = __LINE__ } +} +{ + test_out(" # Subtest: namehere"); + test_out(" 1..3"); + test_out(" ok 1 - first is good"); + test_out(" not ok 2 - second is bad"); + test_err(" # Failed test 'second is bad'"); + test_err(" # at $0 line $line{innerfail3}."); + test_out(" ok 3 - third is good"); + test_err(" # Looks like you failed 1 test of 3."); + test_out("not ok 1 - namehere"); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line $line{outerfail3}."); + + run_the_subtest(); + + test_test("subtest() called from a sub"); +} +{ + test_out( " # Subtest: namehere"); + test_out( " 1..0"); + test_err( " # No tests run!"); + test_out( 'not ok 1 - No tests run for subtest "namehere"'); + test_err(q{# Failed test 'No tests run for subtest "namehere"'}); + test_err( "# at $0 line $line{outerfail4}."); + + subtest namehere => sub { + done_testing; + }; BEGIN{ $line{outerfail4} = __LINE__ } + + test_test("lineno in 'No tests run' diagnostic"); +} +{ + test_out(" # Subtest: namehere"); + test_out(" 1..1"); + test_out(" not ok 1 - foo is bar"); + test_err(" # Failed test 'foo is bar'"); + test_err(" # at $0 line $line{is_fail}."); + test_err(" # got: 'foo'"); + test_err(" # expected: 'bar'"); + test_err(" # Looks like you failed 1 test of 1."); + test_out('not ok 1 - namehere'); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line $line{is_outer_fail}."); + + subtest namehere => sub { + plan tests => 1; + is 'foo', 'bar', 'foo is bar'; BEGIN{ $line{is_fail} = __LINE__ } + }; BEGIN{ $line{is_outer_fail} = __LINE__ } + + test_test("diag indent for is() in subtest"); +} diff --git a/cpan/Test-Simple/t/subtest/plan.t b/cpan/Test-Simple/t/subtest/plan.t new file mode 100644 index 0000000000..7e944ab283 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/plan.t @@ -0,0 +1,49 @@ +#!/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 => 6; + +# Formatting may change if we're running under Test::Harness. +$ENV{HARNESS_ACTIVE} = 0; + +{ + ok defined &subtest, 'subtest() should be exported to our namespace'; + is prototype('subtest'), undef, '... has no prototype'; + + subtest 'subtest with plan', sub { + plan tests => 2; + ok 1, 'planned subtests should work'; + ok 1, '... and support more than one test'; + }; + subtest 'subtest without plan', sub { + plan 'no_plan'; + ok 1, 'no_plan subtests should work'; + ok 1, '... and support more than one test'; + ok 1, '... no matter how many tests are run'; + }; + subtest 'subtest with implicit done_testing()', sub { + ok 1, 'subtests with an implicit done testing should work'; + ok 1, '... and support more than one test'; + ok 1, '... no matter how many tests are run'; + }; + subtest 'subtest with explicit done_testing()', sub { + ok 1, 'subtests with an explicit done testing should work'; + ok 1, '... and support more than one test'; + ok 1, '... no matter how many tests are run'; + done_testing(); + }; +} diff --git a/cpan/Test-Simple/t/subtest/predicate.t b/cpan/Test-Simple/t/subtest/predicate.t new file mode 100644 index 0000000000..4e29a426b1 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/predicate.t @@ -0,0 +1,166 @@ +#!/usr/bin/perl -w + +# Test the use of subtest() to define new test predicates that combine +# multiple existing predicates. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::More tests => 5; +use Test::Builder; +use Test::Builder::Tester; + +# Formatting may change if we're running under Test::Harness. +$ENV{HARNESS_ACTIVE} = 0; + +our %line; + +# Define a new test predicate with Test::More::subtest(), using +# Test::More predicates as building blocks... + +sub foobar_ok ($;$) { + my ($value, $name) = @_; + $name ||= "foobar_ok"; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + subtest $name => sub { + plan tests => 2; + ok $value =~ /foo/, "foo"; + ok $value =~ /bar/, "bar"; BEGIN{ $line{foobar_ok_bar} = __LINE__ } + }; +} +{ + test_out(" # Subtest: namehere"); + test_out(" 1..2"); + test_out(" ok 1 - foo"); + test_out(" not ok 2 - bar"); + test_err(" # Failed test 'bar'"); + test_err(" # at $0 line $line{foobar_ok_bar}."); + test_err(" # Looks like you failed 1 test of 2."); + test_out("not ok 1 - namehere"); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line ".(__LINE__+2)."."); + + foobar_ok "foot", "namehere"; + + test_test("foobar_ok failing line numbers"); +} + +# Wrap foobar_ok() to make another new predicate... + +sub foobar_ok_2 ($;$) { + my ($value, $name) = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + foobar_ok($value, $name); +} +{ + test_out(" # Subtest: namehere"); + test_out(" 1..2"); + test_out(" ok 1 - foo"); + test_out(" not ok 2 - bar"); + test_err(" # Failed test 'bar'"); + test_err(" # at $0 line $line{foobar_ok_bar}."); + test_err(" # Looks like you failed 1 test of 2."); + test_out("not ok 1 - namehere"); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line ".(__LINE__+2)."."); + + foobar_ok_2 "foot", "namehere"; + + test_test("foobar_ok_2 failing line numbers"); +} + +# Define another new test predicate, this time using +# Test::Builder::subtest() rather than Test::More::subtest()... + +sub barfoo_ok ($;$) { + my ($value, $name) = @_; + $name ||= "barfoo_ok"; + + Test::Builder->new->subtest($name => sub { + plan tests => 2; + ok $value =~ /foo/, "foo"; + ok $value =~ /bar/, "bar"; BEGIN{ $line{barfoo_ok_bar} = __LINE__ } + }); +} +{ + test_out(" # Subtest: namehere"); + test_out(" 1..2"); + test_out(" ok 1 - foo"); + test_out(" not ok 2 - bar"); + test_err(" # Failed test 'bar'"); + test_err(" # at $0 line $line{barfoo_ok_bar}."); + test_err(" # Looks like you failed 1 test of 2."); + test_out("not ok 1 - namehere"); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line ".(__LINE__+2)."."); + + barfoo_ok "foot", "namehere"; + + test_test("barfoo_ok failing line numbers"); +} + +# Wrap barfoo_ok() to make another new predicate... + +sub barfoo_ok_2 ($;$) { + my ($value, $name) = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + barfoo_ok($value, $name); +} +{ + test_out(" # Subtest: namehere"); + test_out(" 1..2"); + test_out(" ok 1 - foo"); + test_out(" not ok 2 - bar"); + test_err(" # Failed test 'bar'"); + test_err(" # at $0 line $line{barfoo_ok_bar}."); + test_err(" # Looks like you failed 1 test of 2."); + test_out("not ok 1 - namehere"); + test_err("# Failed test 'namehere'"); + test_err("# at $0 line ".(__LINE__+2)."."); + + barfoo_ok_2 "foot", "namehere"; + + test_test("barfoo_ok_2 failing line numbers"); +} + +# A subtest-based predicate called from within a subtest +{ + test_out(" # Subtest: outergroup"); + test_out(" 1..2"); + test_out(" ok 1 - this passes"); + test_out(" # Subtest: namehere"); + test_out(" 1..2"); + test_out(" ok 1 - foo"); + test_out(" not ok 2 - bar"); + test_err(" # Failed test 'bar'"); + test_err(" # at $0 line $line{barfoo_ok_bar}."); + test_err(" # Looks like you failed 1 test of 2."); + test_out(" not ok 2 - namehere"); + test_err(" # Failed test 'namehere'"); + test_err(" # at $0 line $line{ipredcall}."); + test_err(" # Looks like you failed 1 test of 2."); + test_out("not ok 1 - outergroup"); + test_err("# Failed test 'outergroup'"); + test_err("# at $0 line $line{outercall}."); + + subtest outergroup => sub { + plan tests => 2; + ok 1, "this passes"; + barfoo_ok_2 "foot", "namehere"; BEGIN{ $line{ipredcall} = __LINE__ } + }; BEGIN{ $line{outercall} = __LINE__ } + + test_test("outergroup with internal barfoo_ok_2 failing line numbers"); +} diff --git a/cpan/Test-Simple/t/subtest/singleton.t b/cpan/Test-Simple/t/subtest/singleton.t new file mode 100644 index 0000000000..0c25261f5b --- /dev/null +++ b/cpan/Test-Simple/t/subtest/singleton.t @@ -0,0 +1,38 @@ +#!/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 => 3; + +{ + + package Test::Singleton; + + use Test::Builder; + my $TB = Test::Builder->new; + + sub singleton_ok ($;$) { + my( $val, $name ) = @_; + $TB->ok( $val, $name ); + } +} + +ok 1, 'TB top level'; +subtest 'doing a subtest' => sub { + plan tests => 4; + ok 1, 'first test in subtest'; + Test::Singleton::singleton_ok(1, 'this should not fail'); + ok 1, 'second test in subtest'; + Test::Singleton::singleton_ok(1, 'this should not fail'); +}; +ok 1, 'left subtest'; diff --git a/cpan/Test-Simple/t/subtest/threads.t b/cpan/Test-Simple/t/subtest/threads.t new file mode 100644 index 0000000000..0d70b1e6e5 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/threads.t @@ -0,0 +1,25 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +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 Test::More; + +subtest 'simple test with threads on' => sub { + is( 1+1, 2, "simple test" ); + is( "a", "a", "another simple test" ); +}; + +pass("Parent retains sharedness"); + +done_testing(2); diff --git a/cpan/Test-Simple/t/subtest/todo.t b/cpan/Test-Simple/t/subtest/todo.t new file mode 100644 index 0000000000..7269da9b95 --- /dev/null +++ b/cpan/Test-Simple/t/subtest/todo.t @@ -0,0 +1,200 @@ +#!/usr/bin/perl -w + +# Test todo subtests. +# +# A subtest in a todo context should have all of its diagnostic output +# redirected to the todo output destination, but individual tests +# within the subtest should not become todo tests themselves. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::More; +use Test::Builder; +use Test::Builder::Tester; + +# Formatting may change if we're running under Test::Harness. +$ENV{HARNESS_ACTIVE} = 0; + +our %line; + +# Repeat each test for various combinations of the todo reason, +# the mechanism by which it is set and $Level. +our @test_combos; +foreach my $level (1, 2, 3) { + push @test_combos, ['$TODO', 'Reason', $level], + ['todo_start', 'Reason', $level], + ['todo_start', '', $level], + ['todo_start', 0, $level]; +} + +plan tests => 8 * @test_combos; + +sub test_subtest_in_todo { + my ($name, $code, $want_out, $no_tests_run) = @_; + + my $xxx = $no_tests_run ? 'No tests run for subtest "xxx"' : 'xxx'; + + chomp $want_out; + my @outlines = split /\n/, $want_out; + + foreach my $combo (@test_combos) { + my ($set_via, $todo_reason, $level) = @$combo; + + test_out( + " # Subtest: xxx", + @outlines, + "not ok 1 - $xxx # TODO $todo_reason", + "# Failed (TODO) test '$xxx'", + "# at $0 line $line{xxx}.", + "not ok 2 - regular todo test # TODO $todo_reason", + "# Failed (TODO) test 'regular todo test'", + "# at $0 line $line{reg}.", + ); + + { + local $TODO = $set_via eq '$TODO' ? $todo_reason : undef; + if ($set_via eq 'todo_start') { + Test::Builder->new->todo_start($todo_reason); + } + + subtest_at_level( + 'xxx', $code, $level); BEGIN{ $line{xxx} = __LINE__ } + ok 0, 'regular todo test'; BEGIN{ $line{reg} = __LINE__ } + + if ($set_via eq 'todo_start') { + Test::Builder->new->todo_end; + } + } + + test_test("$name ($level), todo [$todo_reason] set via $set_via"); + } +} + +package Foo; # If several stack frames are in package 'main' then $Level + # could be wrong and $main::TODO might still be found. Using + # another package makes the tests more sensitive. + +sub main::subtest_at_level { + my ($name, $code, $level) = @_; + + if ($level > 1) { + local $Test::Builder::Level = $Test::Builder::Level + 1; + main::subtest_at_level($name, $code, $level-1); + } + else { + Test::Builder->new->subtest($name => $code); + } +} + +package main; + +test_subtest_in_todo("plan, no tests run", sub { + plan tests => 2; +}, < 17; + ok 0, 'failme'; BEGIN { $line{fail2} = __LINE__ } +}, <new->todo_start('Inner2'); + ok 0, 'failing TODO b'; BEGIN{ $line{ftb} = __LINE__ } + ok 1, 'unexpected pass b'; + Test::Builder->new->todo_end; + + ok 0, 'inner test 3'; BEGIN{ $line{in3} = __LINE__ } +}, < sub { + plan tests => 1; + $? = 1; + pass('bar'); +}; + +is $?, 1, "exit code keeps on from a subtest"; + +subtest foo2 => sub { + plan tests => 1; + pass('bar2'); + $? = 1; +}; + +is $?, 1, "exit code keeps on from a subtest"; + +done_testing(4); 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..2c8cace491 --- /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' ); +no_warnings; + +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 74 +cmp_ok( undef, '<=', 2, ' undef <= 2' ); +warnings_like(qr/Use of uninitialized value.* at \(eval in cmp_ok\) $Filename line 74\.\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..9e858bc75e --- /dev/null +++ b/cpan/Test-Simple/t/use_ok.t @@ -0,0 +1,103 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use lib 't/lib'; +use Test::More; + +note "Basic use_ok"; { + package Foo::one; + ::use_ok("Symbol"); + ::ok( defined &gensym, 'use_ok() no args exports defaults' ); +} + + +note "With one arg"; { + package Foo::two; + ::use_ok("Symbol", qw(qualify)); + ::ok( !defined &gensym, ' one arg, defaults overridden' ); + ::ok( defined &qualify, ' right function exported' ); +} + + +note "Multiple args"; { + package Foo::three; + ::use_ok("Symbol", qw(gensym ungensym)); + ::ok( defined &gensym && defined &ungensym, ' multiple args' ); +} + + +note "Defining constants"; { + 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'); +} + + +note "use Module VERSION"; { + package Foo::five; + ::use_ok("Symbol", 1.02); +} + + +note "use Module VERSION does not call import"; { + 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); +} + + +note "Signals are preserved"; { + package Foo::eight; + local $SIG{__DIE__}; + ::use_ok("SigDie"); + ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved'); +} + + +note "Line numbers preserved"; { + my $package = "that_cares_about_line_numbers"; + + # Store the output of caller. + my @caller; + { + package that_cares_about_line_numbers; + + sub import { + @caller = caller; + return; + } + + $INC{"$package.pm"} = 1; # fool use into thinking it's already loaded + } + + ::use_ok($package); + my $line = __LINE__-1; + ::is( $caller[0], __PACKAGE__, "caller package preserved" ); + ::is( $caller[1], __FILE__, " file" ); + ::is( $caller[2], $line, " line" ); +} + + +note "not confused by functions vs class names"; { + $INC{"ok.pm"} = 1; + use_ok("ok"); # ok is a function inside Test::More + + $INC{"Foo/bar.pm"} = 1; + sub Foo::bar { 42 } + use_ok("Foo::bar"); # Confusing a class name with a function name +} + +done_testing; 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..f68b2a7680 --- /dev/null +++ b/cpan/Test-Simple/t/utf8.t @@ -0,0 +1,67 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; +use warnings; + +my $have_perlio; +BEGIN { + # All together so Test::More sees the open discipline + $have_perlio = eval q[ + require PerlIO; + binmode *STDOUT, ":encoding(utf8)"; + binmode *STDERR, ":encoding(utf8)"; + require 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"; + } +} + + +# Test utf8 is ok. +{ + 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..cb83599364 --- /dev/null +++ b/cpan/Test-Simple/t/versions.t @@ -0,0 +1,28 @@ +#!/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 ); + +my @modules = qw( + Test::Simple + Test::Builder + Test::Builder::Module +); + +for my $module (@modules) { + is( $dist_version, $module->VERSION, $module ); +} + +done_testing(4); diff --git a/cpan/Test-Simple/t/xt/dependents.t b/cpan/Test-Simple/t/xt/dependents.t new file mode 100644 index 0000000000..04b9a766b8 --- /dev/null +++ b/cpan/Test-Simple/t/xt/dependents.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +# Test important dependant modules so we don't accidentally half of CPAN. + +use strict; +use warnings; + +use Test::More; + +BEGIN { + plan skip_all => "Dependents only tested when releasing" unless $ENV{PERL_RELEASING}; +} + +require File::Spec; +use CPAN; + +CPAN::HandleConfig->load; +$CPAN::Config->{test_report} = 0; + +# Module which depend on Test::More to test +my @Modules = qw( + Test::Tester + Test::Most + Test::Warn + Test::Exception + Test::Class + Test::Deep + Test::Differences + Test::NoWarnings +); + +# Modules which are known to be broken +my %Broken = map { $_ => 1 } ( + 'Test::Most', + 'Test::Differences' +); + +# Have to do it here because CPAN chdirs. +my $perl5lib = join ":", File::Spec->rel2abs("blib/lib"), File::Spec->rel2abs("lib"); + +TODO: for my $name (@ARGV ? @ARGV : @Modules) { + local $TODO = "$name known to be broken" if $Broken{$name}; + local $ENV{PERL5LIB} = $perl5lib; + + my $module = CPAN::Shell->expand("Module", $name); + $module->make; + $module->test; + my $test_result = $module->distribution->{make_test}; + ok( $test_result && !$test_result->failed, $name ); +} +done_testing(); diff --git a/cpan/Test-Simple/t/xxx-changes_updated.t b/cpan/Test-Simple/t/xxx-changes_updated.t new file mode 100644 index 0000000000..d813d8a7c7 --- /dev/null +++ b/cpan/Test-Simple/t/xxx-changes_updated.t @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test::More; +use List::Util qw/first/; + +plan skip_all => "Only tested when releasing" unless $ENV{AUTHOR_TESTING}; + +my $ver = $Test::More::VERSION; + +my $changes = first { -f $_ } './Changes', '../Changes'; + +plan 'skip_all' => 'Could not find changes file' + unless $changes; + +open(my $fh, '<', $changes) || die "Could not load changes file!"; +chomp(my $line = <$fh>); +like($line, qr/^\Q$ver\E/, "Changes file is up to date"); +close($fh); + +done_testing; -- cgit v1.2.1