diff --git a/MANIFEST b/MANIFEST index e530a1577cd..c45c902fa8b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4483,10 +4483,12 @@ dist/Test/t/success.t See if Test works dist/Test/t/todo.t See if Test works dist/Test-Simple/lib/ok.pm dist/Test-Simple/lib/Test/Builder.pm +dist/Test-Simple/lib/Test/Builder/Formatter.pm dist/Test-Simple/lib/Test/Builder/IO/Scalar.pm dist/Test-Simple/lib/Test/Builder/Module.pm dist/Test-Simple/lib/Test/Builder/Tester.pm dist/Test-Simple/lib/Test/Builder/Tester/Color.pm +dist/Test-Simple/lib/Test/Builder/TodoDiag.pm dist/Test-Simple/lib/Test/More.pm dist/Test-Simple/lib/Test/Simple.pm dist/Test-Simple/lib/Test/Tester.pm @@ -4495,73 +4497,177 @@ dist/Test-Simple/lib/Test/Tester/CaptureRunner.pm dist/Test-Simple/lib/Test/Tester/Delegate.pm dist/Test-Simple/lib/Test/Tutorial.pod dist/Test-Simple/lib/Test/use/ok.pm -dist/Test-Simple/t/00test_harness_check.t -dist/Test-Simple/t/01-basic.t -dist/Test-Simple/t/478-cmp_ok_hash.t -dist/Test-Simple/t/auto.t -dist/Test-Simple/t/bad_plan.t -dist/Test-Simple/t/bail_out.t -dist/Test-Simple/t/BEGIN_require_ok.t -dist/Test-Simple/t/BEGIN_use_ok.t -dist/Test-Simple/t/buffer.t -dist/Test-Simple/t/Builder/Builder.t -dist/Test-Simple/t/Builder/carp.t -dist/Test-Simple/t/Builder/create.t -dist/Test-Simple/t/Builder/current_test.t -dist/Test-Simple/t/Builder/current_test_without_plan.t -dist/Test-Simple/t/Builder/details.t -dist/Test-Simple/t/Builder/done_testing.t -dist/Test-Simple/t/Builder/done_testing_double.t -dist/Test-Simple/t/Builder/done_testing_plan_mismatch.t -dist/Test-Simple/t/Builder/done_testing_with_no_plan.t -dist/Test-Simple/t/Builder/done_testing_with_number.t -dist/Test-Simple/t/Builder/done_testing_with_plan.t -dist/Test-Simple/t/Builder/fork_with_new_stdout.t -dist/Test-Simple/t/Builder/has_plan.t -dist/Test-Simple/t/Builder/has_plan2.t -dist/Test-Simple/t/Builder/is_fh.t -dist/Test-Simple/t/Builder/is_passing.t -dist/Test-Simple/t/Builder/maybe_regex.t -dist/Test-Simple/t/Builder/no_diag.t -dist/Test-Simple/t/Builder/no_ending.t -dist/Test-Simple/t/Builder/no_header.t -dist/Test-Simple/t/Builder/no_plan_at_all.t -dist/Test-Simple/t/Builder/ok_obj.t -dist/Test-Simple/t/Builder/output.t -dist/Test-Simple/t/Builder/reset.t -dist/Test-Simple/t/Builder/reset_outputs.t -dist/Test-Simple/t/Builder/try.t -dist/Test-Simple/t/c_flag.t -dist/Test-Simple/t/capture.t -dist/Test-Simple/t/check_tests.t -dist/Test-Simple/t/circular_data.t -dist/Test-Simple/t/cmp_ok.t -dist/Test-Simple/t/dependents.t -dist/Test-Simple/t/depth.t -dist/Test-Simple/t/diag.t -dist/Test-Simple/t/died.t -dist/Test-Simple/t/dont_overwrite_die_handler.t -dist/Test-Simple/t/eq_set.t -dist/Test-Simple/t/exit.t -dist/Test-Simple/t/explain.t -dist/Test-Simple/t/extra.t -dist/Test-Simple/t/extra_one.t -dist/Test-Simple/t/fail.t -dist/Test-Simple/t/fail-like.t -dist/Test-Simple/t/fail-more.t -dist/Test-Simple/t/fail_one.t -dist/Test-Simple/t/filehandles.t -dist/Test-Simple/t/fork.t -dist/Test-Simple/t/harness_active.t -dist/Test-Simple/t/import.t -dist/Test-Simple/t/is_deeply_dne_bug.t -dist/Test-Simple/t/is_deeply_fail.t -dist/Test-Simple/t/is_deeply_with_threads.t +dist/Test-Simple/lib/Test2.pm +dist/Test-Simple/lib/Test2/API.pm +dist/Test-Simple/lib/Test2/API/Breakage.pm +dist/Test-Simple/lib/Test2/API/Context.pm +dist/Test-Simple/lib/Test2/API/Instance.pm +dist/Test-Simple/lib/Test2/API/Stack.pm +dist/Test-Simple/lib/Test2/Event.pm +dist/Test-Simple/lib/Test2/Event/Bail.pm +dist/Test-Simple/lib/Test2/Event/Diag.pm +dist/Test-Simple/lib/Test2/Event/Encoding.pm +dist/Test-Simple/lib/Test2/Event/Exception.pm +dist/Test-Simple/lib/Test2/Event/Generic.pm +dist/Test-Simple/lib/Test2/Event/Info.pm +dist/Test-Simple/lib/Test2/Event/Note.pm +dist/Test-Simple/lib/Test2/Event/Ok.pm +dist/Test-Simple/lib/Test2/Event/Plan.pm +dist/Test-Simple/lib/Test2/Event/Skip.pm +dist/Test-Simple/lib/Test2/Event/Subtest.pm +dist/Test-Simple/lib/Test2/Event/TAP/Version.pm +dist/Test-Simple/lib/Test2/Event/Waiting.pm +dist/Test-Simple/lib/Test2/Formatter.pm +dist/Test-Simple/lib/Test2/Formatter/TAP.pm +dist/Test-Simple/lib/Test2/Hub.pm +dist/Test-Simple/lib/Test2/Hub/Interceptor.pm +dist/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm +dist/Test-Simple/lib/Test2/Hub/Subtest.pm +dist/Test-Simple/lib/Test2/IPC.pm +dist/Test-Simple/lib/Test2/IPC/Driver.pm +dist/Test-Simple/lib/Test2/IPC/Driver/Files.pm +dist/Test-Simple/lib/Test2/Tools/Tiny.pm +dist/Test-Simple/lib/Test2/Transition.pod +dist/Test-Simple/lib/Test2/Util.pm +dist/Test-Simple/lib/Test2/Util/ExternalMeta.pm +dist/Test-Simple/lib/Test2/Util/HashBase.pm +dist/Test-Simple/lib/Test2/Util/Trace.pm +dist/Test-Simple/t/00-report.t +dist/Test-Simple/t/Legacy/00test_harness_check.t +dist/Test-Simple/t/Legacy/01-basic.t +dist/Test-Simple/t/Legacy/478-cmp_ok_hash.t +dist/Test-Simple/t/Legacy/auto.t +dist/Test-Simple/t/Legacy/bad_plan.t +dist/Test-Simple/t/Legacy/bail_out.t +dist/Test-Simple/t/Legacy/BEGIN_require_ok.t +dist/Test-Simple/t/Legacy/BEGIN_use_ok.t +dist/Test-Simple/t/Legacy/buffer.t +dist/Test-Simple/t/Legacy/Bugs/600.t +dist/Test-Simple/t/Legacy/Bugs/629.t +dist/Test-Simple/t/Legacy/Builder/Builder.t +dist/Test-Simple/t/Legacy/Builder/carp.t +dist/Test-Simple/t/Legacy/Builder/create.t +dist/Test-Simple/t/Legacy/Builder/current_test.t +dist/Test-Simple/t/Legacy/Builder/current_test_without_plan.t +dist/Test-Simple/t/Legacy/Builder/details.t +dist/Test-Simple/t/Legacy/Builder/done_testing.t +dist/Test-Simple/t/Legacy/Builder/done_testing_double.t +dist/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t +dist/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t +dist/Test-Simple/t/Legacy/Builder/done_testing_with_number.t +dist/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t +dist/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t +dist/Test-Simple/t/Legacy/Builder/has_plan.t +dist/Test-Simple/t/Legacy/Builder/has_plan2.t +dist/Test-Simple/t/Legacy/Builder/is_fh.t +dist/Test-Simple/t/Legacy/Builder/is_passing.t +dist/Test-Simple/t/Legacy/Builder/maybe_regex.t +dist/Test-Simple/t/Legacy/Builder/no_diag.t +dist/Test-Simple/t/Legacy/Builder/no_ending.t +dist/Test-Simple/t/Legacy/Builder/no_header.t +dist/Test-Simple/t/Legacy/Builder/no_plan_at_all.t +dist/Test-Simple/t/Legacy/Builder/ok_obj.t +dist/Test-Simple/t/Legacy/Builder/output.t +dist/Test-Simple/t/Legacy/Builder/reset.t +dist/Test-Simple/t/Legacy/Builder/reset_outputs.t +dist/Test-Simple/t/Legacy/Builder/try.t +dist/Test-Simple/t/Legacy/c_flag.t +dist/Test-Simple/t/Legacy/capture.t +dist/Test-Simple/t/Legacy/check_tests.t +dist/Test-Simple/t/Legacy/circular_data.t +dist/Test-Simple/t/Legacy/cmp_ok.t +dist/Test-Simple/t/Legacy/depth.t +dist/Test-Simple/t/Legacy/diag.t +dist/Test-Simple/t/Legacy/died.t +dist/Test-Simple/t/Legacy/dont_overwrite_die_handler.t +dist/Test-Simple/t/Legacy/eq_set.t +dist/Test-Simple/t/Legacy/exit.t +dist/Test-Simple/t/Legacy/explain.t +dist/Test-Simple/t/Legacy/explain_err_vars.t +dist/Test-Simple/t/Legacy/extra.t +dist/Test-Simple/t/Legacy/extra_one.t +dist/Test-Simple/t/Legacy/fail.t +dist/Test-Simple/t/Legacy/fail-like.t +dist/Test-Simple/t/Legacy/fail-more.t +dist/Test-Simple/t/Legacy/fail_one.t +dist/Test-Simple/t/Legacy/filehandles.t +dist/Test-Simple/t/Legacy/fork.t +dist/Test-Simple/t/Legacy/harness_active.t +dist/Test-Simple/t/Legacy/import.t +dist/Test-Simple/t/Legacy/is_deeply_dne_bug.t +dist/Test-Simple/t/Legacy/is_deeply_fail.t +dist/Test-Simple/t/Legacy/is_deeply_with_threads.t +dist/Test-Simple/t/Legacy/missing.t +dist/Test-Simple/t/Legacy/More.t +dist/Test-Simple/t/Legacy/new_ok.t +dist/Test-Simple/t/Legacy/no_plan.t +dist/Test-Simple/t/Legacy/no_tests.t +dist/Test-Simple/t/Legacy/note.t +dist/Test-Simple/t/Legacy/overload.t +dist/Test-Simple/t/Legacy/overload_threads.t +dist/Test-Simple/t/Legacy/plan.t +dist/Test-Simple/t/Legacy/plan_bad.t +dist/Test-Simple/t/Legacy/plan_is_noplan.t +dist/Test-Simple/t/Legacy/plan_no_plan.t +dist/Test-Simple/t/Legacy/plan_shouldnt_import.t +dist/Test-Simple/t/Legacy/plan_skip_all.t +dist/Test-Simple/t/Legacy/Regression/637.t +dist/Test-Simple/t/Legacy/Regression/683_thread_todo.t +dist/Test-Simple/t/Legacy/Regression/6_cmp_ok.t +dist/Test-Simple/t/Legacy/Regression/736_use_ok.t +dist/Test-Simple/t/Legacy/require_ok.t +dist/Test-Simple/t/Legacy/run_test.t +dist/Test-Simple/t/Legacy/simple.t +dist/Test-Simple/t/Legacy/Simple/load.t +dist/Test-Simple/t/Legacy/skip.t +dist/Test-Simple/t/Legacy/skipall.t +dist/Test-Simple/t/Legacy/strays.t +dist/Test-Simple/t/Legacy/subtest/args.t +dist/Test-Simple/t/Legacy/subtest/bail_out.t +dist/Test-Simple/t/Legacy/subtest/basic.t +dist/Test-Simple/t/Legacy/subtest/die.t +dist/Test-Simple/t/Legacy/subtest/do.t +dist/Test-Simple/t/Legacy/subtest/events.t +dist/Test-Simple/t/Legacy/subtest/for_do_t.test +dist/Test-Simple/t/Legacy/subtest/fork.t +dist/Test-Simple/t/Legacy/subtest/implicit_done.t +dist/Test-Simple/t/Legacy/subtest/line_numbers.t +dist/Test-Simple/t/Legacy/subtest/plan.t +dist/Test-Simple/t/Legacy/subtest/predicate.t +dist/Test-Simple/t/Legacy/subtest/singleton.t +dist/Test-Simple/t/Legacy/subtest/threads.t +dist/Test-Simple/t/Legacy/subtest/todo.t +dist/Test-Simple/t/Legacy/subtest/wstat.t +dist/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t +dist/Test-Simple/t/Legacy/Test2/Subtest.t +dist/Test-Simple/t/Legacy/Tester/tbt_01basic.t +dist/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t +dist/Test-Simple/t/Legacy/Tester/tbt_03die.t +dist/Test-Simple/t/Legacy/Tester/tbt_04line_num.t +dist/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t +dist/Test-Simple/t/Legacy/Tester/tbt_06errormess.t +dist/Test-Simple/t/Legacy/Tester/tbt_07args.t +dist/Test-Simple/t/Legacy/Tester/tbt_08subtest.t +dist/Test-Simple/t/Legacy/Tester/tbt_09do.t +dist/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl +dist/Test-Simple/t/Legacy/thread_taint.t +dist/Test-Simple/t/Legacy/threads.t +dist/Test-Simple/t/Legacy/todo.t +dist/Test-Simple/t/Legacy/undef.t +dist/Test-Simple/t/Legacy/use_ok.t +dist/Test-Simple/t/Legacy/useing.t +dist/Test-Simple/t/Legacy/utf8.t +dist/Test-Simple/t/Legacy/versions.t +dist/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t +dist/Test-Simple/t/Legacy_And_Test2/hidden_warnings.t dist/Test-Simple/t/lib/Dev/Null.pm dist/Test-Simple/t/lib/Dummy.pm dist/Test-Simple/t/lib/MyOverload.pm +dist/Test-Simple/t/lib/MyTest.pm dist/Test-Simple/t/lib/NoExporter.pm dist/Test-Simple/t/lib/SigDie.pm +dist/Test-Simple/t/lib/SkipAll.pm +dist/Test-Simple/t/lib/SmallTest.pm dist/Test-Simple/t/lib/Test/Builder/NoOutput.pm dist/Test-Simple/t/lib/Test/Simple/Catch.pm dist/Test-Simple/t/lib/Test/Simple/sample_tests/death.plx @@ -4581,63 +4687,68 @@ dist/Test-Simple/t/lib/Test/Simple/sample_tests/too_few.plx dist/Test-Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx dist/Test-Simple/t/lib/Test/Simple/sample_tests/two_fail.plx dist/Test-Simple/t/lib/TieOut.pm -dist/Test-Simple/t/missing.t -dist/Test-Simple/t/More.t -dist/Test-Simple/t/MyTest.pm -dist/Test-Simple/t/new_ok.t -dist/Test-Simple/t/no_plan.t -dist/Test-Simple/t/no_tests.t -dist/Test-Simple/t/note.t -dist/Test-Simple/t/overload.t -dist/Test-Simple/t/overload_threads.t -dist/Test-Simple/t/plan.t -dist/Test-Simple/t/plan_bad.t -dist/Test-Simple/t/plan_is_noplan.t -dist/Test-Simple/t/plan_no_plan.t -dist/Test-Simple/t/plan_shouldnt_import.t -dist/Test-Simple/t/plan_skip_all.t -dist/Test-Simple/t/require_ok.t -dist/Test-Simple/t/run_test.t -dist/Test-Simple/t/simple.t -dist/Test-Simple/t/Simple/load.t -dist/Test-Simple/t/skip.t -dist/Test-Simple/t/skipall.t -dist/Test-Simple/t/SmallTest.pm -dist/Test-Simple/t/subtest/args.t -dist/Test-Simple/t/subtest/bail_out.t -dist/Test-Simple/t/subtest/basic.t -dist/Test-Simple/t/subtest/die.t -dist/Test-Simple/t/subtest/do.t -dist/Test-Simple/t/subtest/exceptions.t -dist/Test-Simple/t/subtest/for_do_t.test -dist/Test-Simple/t/subtest/fork.t -dist/Test-Simple/t/subtest/implicit_done.t -dist/Test-Simple/t/subtest/line_numbers.t -dist/Test-Simple/t/subtest/plan.t -dist/Test-Simple/t/subtest/predicate.t -dist/Test-Simple/t/subtest/singleton.t -dist/Test-Simple/t/subtest/threads.t -dist/Test-Simple/t/subtest/todo.t -dist/Test-Simple/t/subtest/wstat.t -dist/Test-Simple/t/tbm_doesnt_set_exported_to.t -dist/Test-Simple/t/Tester/tbt_01basic.t -dist/Test-Simple/t/Tester/tbt_02fhrestore.t -dist/Test-Simple/t/Tester/tbt_03die.t -dist/Test-Simple/t/Tester/tbt_04line_num.t -dist/Test-Simple/t/Tester/tbt_05faildiag.t -dist/Test-Simple/t/Tester/tbt_06errormess.t -dist/Test-Simple/t/Tester/tbt_07args.t -dist/Test-Simple/t/Tester/tbt_08subtest.t -dist/Test-Simple/t/Tester/tbt_09do.t -dist/Test-Simple/t/Tester/tbt_09do_script.pl -dist/Test-Simple/t/thread_taint.t -dist/Test-Simple/t/threads.t -dist/Test-Simple/t/todo.t -dist/Test-Simple/t/undef.t -dist/Test-Simple/t/use_ok.t -dist/Test-Simple/t/useing.t -dist/Test-Simple/t/utf8.t -dist/Test-Simple/t/versions.t +dist/Test-Simple/t/regression/642_persistent_end.t +dist/Test-Simple/t/regression/662-tbt-no-plan.t +dist/Test-Simple/t/regression/684-nested_todo_diag.t +dist/Test-Simple/t/regression/694_note_diag_return_values.t +dist/Test-Simple/t/regression/696-intercept_skip_all.t +dist/Test-Simple/t/regression/721-nested-streamed-subtest.t +dist/Test-Simple/t/regression/no_name_in_subtest.t +dist/Test-Simple/t/Test2/acceptance/try_it_done_testing.t +dist/Test-Simple/t/Test2/acceptance/try_it_fork.t +dist/Test-Simple/t/Test2/acceptance/try_it_no_plan.t +dist/Test-Simple/t/Test2/acceptance/try_it_plan.t +dist/Test-Simple/t/Test2/acceptance/try_it_skip.t +dist/Test-Simple/t/Test2/acceptance/try_it_threads.t +dist/Test-Simple/t/Test2/acceptance/try_it_todo.t +dist/Test-Simple/t/Test2/behavior/err_var.t +dist/Test-Simple/t/Test2/behavior/Formatter.t +dist/Test-Simple/t/Test2/behavior/init_croak.t +dist/Test-Simple/t/Test2/behavior/nested_context_exception.t +dist/Test-Simple/t/Test2/behavior/no_load_api.t +dist/Test-Simple/t/Test2/behavior/run_subtest_inherit.t +dist/Test-Simple/t/Test2/behavior/special_names.t +dist/Test-Simple/t/Test2/behavior/Subtest_buffer_formatter.t +dist/Test-Simple/t/Test2/behavior/Subtest_events.t +dist/Test-Simple/t/Test2/behavior/Subtest_plan.t +dist/Test-Simple/t/Test2/behavior/Subtest_todo.t +dist/Test-Simple/t/Test2/behavior/Taint.t +dist/Test-Simple/t/Test2/behavior/trace_signature.t +dist/Test-Simple/t/Test2/legacy/TAP.t +dist/Test-Simple/t/Test2/modules/API.t +dist/Test-Simple/t/Test2/modules/API/Breakage.t +dist/Test-Simple/t/Test2/modules/API/Context.t +dist/Test-Simple/t/Test2/modules/API/Instance.t +dist/Test-Simple/t/Test2/modules/API/Stack.t +dist/Test-Simple/t/Test2/modules/Event.t +dist/Test-Simple/t/Test2/modules/Event/Bail.t +dist/Test-Simple/t/Test2/modules/Event/Diag.t +dist/Test-Simple/t/Test2/modules/Event/Exception.t +dist/Test-Simple/t/Test2/modules/Event/Generic.t +dist/Test-Simple/t/Test2/modules/Event/Info.t +dist/Test-Simple/t/Test2/modules/Event/Note.t +dist/Test-Simple/t/Test2/modules/Event/Ok.t +dist/Test-Simple/t/Test2/modules/Event/Plan.t +dist/Test-Simple/t/Test2/modules/Event/Skip.t +dist/Test-Simple/t/Test2/modules/Event/Subtest.t +dist/Test-Simple/t/Test2/modules/Event/Waiting.t +dist/Test-Simple/t/Test2/modules/Formatter/TAP.t +dist/Test-Simple/t/Test2/modules/Hub.t +dist/Test-Simple/t/Test2/modules/Hub/Interceptor.t +dist/Test-Simple/t/Test2/modules/Hub/Interceptor/Terminator.t +dist/Test-Simple/t/Test2/modules/Hub/Subtest.t +dist/Test-Simple/t/Test2/modules/IPC.t +dist/Test-Simple/t/Test2/modules/IPC/Driver.t +dist/Test-Simple/t/Test2/modules/IPC/Driver/Files.t +dist/Test-Simple/t/Test2/modules/Tools/Tiny.t +dist/Test-Simple/t/Test2/modules/Util.t +dist/Test-Simple/t/Test2/modules/Util/ExternalMeta.t +dist/Test-Simple/t/Test2/modules/Util/HashBase.t +dist/Test-Simple/t/Test2/modules/Util/Trace.t +dist/Test-Simple/t/Test2/regression/693_ipc_ordering.t +dist/Test-Simple/t/Test2/regression/746-forking-subtest.t +dist/Test-Simple/t/Test2/regression/gh_16.t +dist/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t dist/Text-Abbrev/lib/Text/Abbrev.pm An abbreviation table builder dist/Text-Abbrev/t/Abbrev.t Test Text::Abbrev dist/Thread-Queue/lib/Thread/Queue.pm Thread-safe queues diff --git a/Makefile.SH b/Makefile.SH index 7ea8d284b5a..88cd4b93fad 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -1719,27 +1719,30 @@ _cleaner2: -rmdir lib/autodie/Scope lib/autodie lib/YAML lib/XS lib/Win32API -rmdir lib/VMS lib/Unicode/Collate/Locale lib/Unicode/Collate/CJK -rmdir lib/Unicode/Collate lib/Tie/Hash lib/Thread lib/Text - -rmdir lib/Test/use lib/Test/Tester lib/Test/Builder/Tester - -rmdir lib/Test/Builder/IO lib/Test/Builder lib/Test lib/Term - -rmdir lib/TAP/Parser/YAMLish lib/TAP/Parser/SourceHandler - -rmdir lib/TAP/Parser/Scheduler lib/TAP/Parser/Result - -rmdir lib/TAP/Parser/Iterator lib/TAP/Parser lib/TAP/Harness - -rmdir lib/TAP/Formatter/File lib/TAP/Formatter/Console - -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Sub - -rmdir lib/Stash lib/Search lib/Scalar lib/Pod/Text lib/Pod/Simple - -rmdir lib/Pod/Perldoc lib/PerlIO/via lib/PerlIO lib/Perl - -rmdir lib/Parse/CPAN lib/Parse lib/Params lib/Net/FTP - -rmdir lib/Module/Load lib/Module/CoreList lib/Module lib/Memoize - -rmdir lib/Math/BigInt lib/Math/BigFloat lib/Math lib/MIME - -rmdir lib/Locale/Maketext lib/Locale lib/List/Util lib/List - -rmdir lib/LibYAML/lib/YAML/XS lib/LibYAML/lib/YAML lib/LibYAML/lib - -rmdir lib/LibYAML lib/JSON/PP lib/JSON lib/Internals lib/IPC - -rmdir lib/IO/Uncompress/Adapter lib/IO/Uncompress lib/IO/Socket - -rmdir lib/IO/Compress/Zlib lib/IO/Compress/Zip - -rmdir lib/IO/Compress/Gzip lib/IO/Compress/Base - -rmdir lib/IO/Compress/Adapter lib/IO/Compress lib/IO - -rmdir lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash lib/HTTP - -rmdir lib/Filter/Util lib/Filter lib/File/Spec + -rmdir lib/Test2/Util lib/Test2/Tools lib/Test2/IPC/Driver + -rmdir lib/Test2/IPC lib/Test2/Hub/Interceptor lib/Test2/Hub + -rmdir lib/Test2/Formatter lib/Test2/Event/TAP lib/Test2/Event + -rmdir lib/Test2/API lib/Test2 lib/Test/use lib/Test/Tester + -rmdir lib/Test/Builder/Tester lib/Test/Builder/IO lib/Test/Builder + -rmdir lib/Test lib/Term lib/TAP/Parser/YAMLish + -rmdir lib/TAP/Parser/SourceHandler lib/TAP/Parser/Scheduler + -rmdir lib/TAP/Parser/Result lib/TAP/Parser/Iterator lib/TAP/Parser + -rmdir lib/TAP/Harness lib/TAP/Formatter/File + -rmdir lib/TAP/Formatter/Console lib/TAP/Formatter lib/TAP + -rmdir lib/Sys/Syslog lib/Sys lib/Sub lib/Stash lib/Search + -rmdir lib/Scalar lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc + -rmdir lib/PerlIO/via lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse + -rmdir lib/Params lib/Net/FTP lib/Module/Load lib/Module/CoreList + -rmdir lib/Module lib/Memoize lib/Math/BigInt lib/Math/BigFloat + -rmdir lib/Math lib/MIME lib/Locale/Maketext + -rmdir lib/Locale lib/List/Util lib/List lib/LibYAML/lib/YAML/XS + -rmdir lib/LibYAML/lib/YAML lib/LibYAML/lib lib/LibYAML lib/JSON/PP + -rmdir lib/JSON lib/Internals lib/IPC lib/IO/Uncompress/Adapter + -rmdir lib/IO/Uncompress lib/IO/Socket lib/IO/Compress/Zlib + -rmdir lib/IO/Compress/Zip lib/IO/Compress/Gzip + -rmdir lib/IO/Compress/Base lib/IO/Compress/Adapter lib/IO/Compress + -rmdir lib/IO lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash + -rmdir lib/HTTP lib/Filter/Util lib/Filter lib/File/Spec -rmdir lib/ExtUtils/Typemaps lib/ExtUtils/ParseXS -rmdir lib/ExtUtils/MakeMaker/version lib/ExtUtils/MakeMaker -rmdir lib/ExtUtils/Liblist lib/ExtUtils/Constant diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index cad38642395..2a0d2d22ce7 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1379,19 +1379,22 @@ package Maintainers; }, 'Test::Simple' => { - # bumped to 1.4001014 with cperl modernizations. + # cperl modernizations TODO # Test2 based 1.3x versions are not yet modernized, - 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.4001014.tar.gz', + 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302059.tar.gz', 'FILES' => q[dist/Test-Simple], 'EXCLUDED' => [ qr{^t/xt}, qr{^xt}, + qr{^examples}, qw( .perlcriticrc .perltidyrc + appveyor.yml examples/indent.pl examples/subtest.t t/00compile.t t/xxx-changes_updated.t + t/zzz-check-breaks.t ), ], }, diff --git a/dist/Test-Simple/lib/Test/Builder.pm b/dist/Test-Simple/lib/Test/Builder.pm index 72b427a52e6..16126a61180 100644 --- a/dist/Test-Simple/lib/Test/Builder.pm +++ b/dist/Test-Simple/lib/Test/Builder.pm @@ -4,8 +4,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '1.401015c'; # modernized -$VERSION =~ s/c$//; +our $VERSION = '1.302075'; BEGIN { if( $] < 5.008 ) { @@ -13,510 +12,423 @@ BEGIN { } } +use Scalar::Util qw/blessed reftype weaken/; +use Test2::Util qw/USE_THREADS try get_tid/; +use Test2::API qw/context release/; # Make Test::Builder thread-safe for ithreads. BEGIN { - use Config; - # Load threads::shared when threads are turned on. - # 5.8.0's threads are so busted we no longer support them. - if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { - require threads::shared; - - # Hack around YET ANOTHER threads::shared bug. It would - # 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 str $type = ref $_[0]; - my $data; - - if( $type eq 'HASH' ) { - %$data = %{ $_[0] }; - } - elsif( $type eq 'ARRAY' ) { - @$data = @{ $_[0] }; - } - elsif( $type eq 'SCALAR' ) { - $$data = ${ $_[0] }; - } - else { - die( "Unknown type: " . $type ); - } - - $_[0] = &threads::shared::share( $_[0] ); - - if( $type eq 'HASH' ) { - %{ $_[0] } = %$data; - } - elsif( $type eq 'ARRAY' ) { - @{ $_[0] } = @$data; - } - elsif( $type eq 'SCALAR' ) { - ${ $_[0] } = $$data; - } - else { - die( "Unknown type: " . $type ); - } + warn "Test::Builder was loaded after Test2 initialization, this is not recommended." + if Test2::API::test2_init_done() || Test2::API::test2_load_done(); - 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 }; + if (USE_THREADS) { + require Test2::IPC; + require Test2::IPC::Driver::Files; + Test2::IPC::Driver::Files->import; + Test2::API::test2_ipc_enable_polling(); + Test2::API::test2_no_wait(1); + Test2::API::test2_ipc_enable_shm(); } } -=head1 NAME - -Test::Builder - Backend for building test libraries - -=head1 SYNOPSIS +use Test2::Event::Subtest; +use Test2::Hub::Subtest; - package My::Test::Module; - use base 'Test::Builder::Module'; +use Test::Builder::Formatter; +use Test::Builder::TodoDiag; - my $CLASS = __PACKAGE__; +our $Level = 1; +our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; - sub ok { - my($test, $name) = @_; - my $tb = $CLASS->builder; +sub _add_ts_hooks { + my $self = shift; + my $hub = $self->{Stack}->top; - $tb->ok($test, $name); - } + # Take a reference to the hash key, we do this to avoid closing over $self + # which is the singleton. We use a reference because the value could change + # in rare cases. + my $epkgr = \$self->{Exported_To}; + #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1}); -=head1 DESCRIPTION + $hub->pre_filter(sub { + my ($active_hub, $e) = @_; -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. + my $epkg = $$epkgr; + my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef; -=head2 Construction + no strict 'refs'; + no warnings 'once'; + my $todo; + $todo = ${"$cpkg\::TODO"} if $cpkg; + $todo = ${"$epkg\::TODO"} if $epkg && !$todo; -=over 4 + return $e unless $todo; -=item B + # Turn a diag into a todo diag + return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; - my $Test = Test::Builder->new; + # Set todo on ok's + if ($e->isa('Test2::Event::Ok')) { + $e->set_todo($todo); + $e->set_effective_pass(1); -Returns a Test::Builder object representing the current state of the -test. + if (my $result = $e->get_meta(__PACKAGE__)) { + $result->{reason} ||= $todo; + $result->{type} ||= 'todo'; + $result->{ok} = 1; + } + } -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. + return $e; + }, inherit => 1); +} -If you want a completely new Test::Builder object different from the -singleton, use C. +sub new { + my($class) = shift; + unless($Test) { + my $ctx = context(); + $Test = $class->create(singleton => 1); + $ctx->release; -=cut + # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So + # we only want the level to change if $Level != 1. + # TB->ctx compensates for this later. + Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 }); -our $Test = Test::Builder->new; + Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) }); -sub new ($class) :method { - $Test ||= $class->create; + Test2::API::test2_ipc()->set_no_fatal(1) if USE_THREADS; + } 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. +sub create { + my $class = shift; + my %params = @_; -=cut - -sub create ($class) :method { my $self = bless {}, $class; - $self->reset; + if ($params{singleton}) { + $self->{Stack} = Test2::API::test2_stack(); + } + else { + $self->{Stack} = Test2::API::Stack->new; + $self->{Stack}->new_hub( + formatter => Test::Builder::Formatter->new, + ipc => Test2::API::test2_ipc(), + ); + } + $self->reset(%params); + $self->_add_ts_hooks; + 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 ($src, $dest) { - %$dest = %$src; - _share_keys($dest); - return; +sub ctx { + my $self = shift; + context( + # 1 for our frame, another for the -1 off of $Level in our hook at the top. + level => 2, + fudge => 1, + stack => $self->{Stack}, + hub => $self->{Hub}, + wrapped => 1, + @_ + ); } +sub parent { + my $self = shift; + my $ctx = $self->ctx; + my $chub = $self->{Hub} || $ctx->hub; + $ctx->release; -=item B - - 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. + my $parent = $chub->meta(__PACKAGE__, {})->{parent}; -Trying to create a new child with a previous child still active (i.e., -C not called) will C. + return undef unless $parent; -Trying to run a test when you have an open child will also C and cause -the test suite to fail. + return bless { + Original_Pid => $$, + Stack => $self->{Stack}, + Hub => $parent, + }, blessed($self); +} -=cut +sub child { + my( $self, $name ) = @_; -sub child ( $self, $name? ) :method { + $name ||= "Child of " . $self->name; + my $ctx = $self->ctx; - if( $self->{Child_Name} ) { - $self->croak("You already have a child named ($self->{Child_Name}) running"); - } + my $parent = $ctx->hub; + my $pmeta = $parent->meta(__PACKAGE__, {}); + $self->croak("You already have a child named ($pmeta->{child}) running") + if $pmeta->{child}; - my $parent_in_todo = $self->in_todo; + $pmeta->{child} = $name; # Clear $TODO for the child. my $orig_TODO = $self->find_TODO(undef, 1, undef); - my str $class = ref $self; - my $child = $class->create; - - # Add to our indentation - $child->_indent( $self->_indent . ' ' ); + my $subevents = []; - # Make the child use the same outputs as the parent - for my str $method (qw(output failure_output todo_output)) { - $child->$method( $self->$method ); - } + my $hub = $ctx->stack->new_hub( + class => 'Test2::Hub::Subtest', + ); - # Ensure the child understands if they're inside a TODO - if( $parent_in_todo ) { - $child->failure_output( $self->todo_output ); - } + $hub->pre_filter(sub { + my ($active_hub, $e) = @_; - # 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; -} + # Turn a diag into a todo diag + return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; + return $e; + }, inherit => 1) if $orig_TODO; -=item B + $hub->listen(sub { push @$subevents => $_[1] }); - $builder->subtest($name, \&subtests, @args); + $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 ); -See documentation of C in Test::More. + my $meta = $hub->meta(__PACKAGE__, {}); + $meta->{Name} = $name; + $meta->{TODO} = $orig_TODO; + $meta->{TODO_PKG} = $ctx->trace->package; + $meta->{parent} = $parent; + $meta->{Test_Results} = []; + $meta->{subevents} = $subevents; + $meta->{subtest_id} = $hub->id; + $meta->{subtest_buffered} = $parent->format ? 0 : 1; -C also, and optionally, accepts arguments which will be passed to the -subtests reference. + $self->_add_ts_hooks; -=cut + $ctx->release; + return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub }, blessed($self); +} -#sub subtest ($self, $name, $subtests, @args) :prototype($*&@) -sub subtest -{ +sub finalize { my $self = shift; - my($name, $subtests, @args) = @_; - if ('CODE' ne ref $subtests) { - $self->croak("subtest()'s second argument must be a code ref"); - } - - # 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; + my $ok = 1; + ($ok) = @_ if @_; - # 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; - }; + my $st_ctx = $self->ctx; + my $chub = $self->{Hub} || return $st_ctx->release; - if( !eval { $run_the_subtests->() } ) { - $error = $@; - } + my $meta = $chub->meta(__PACKAGE__, {}); + if ($meta->{child}) { + $self->croak("Can't call finalize() with child ($meta->{child}) active"); } - # Restore the parent and the copied child. - _copy($self, $child); - _copy($parent, $self); - - # Restore the parent's $TODO - $self->find_TODO(undef, 1, $child->{Parent_TODO}); - - # Die *after* we restore the parent. - die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $finalize = $child->finalize; - - $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out}; - - return $finalize; -} - -=begin _private - -=item B<_plan_handled> - - if ( $Test->_plan_handled ) { ... } - -Returns true if the developer has explicitly handled the plan via: - -=over 4 - -=item * Explicitly setting the number of tests - -=item * Setting 'no_plan' - -=item * Set 'skip_all'. - -=back - -This is currently used in subtests when we implicitly call C<< $Test->done_testing >> -if the developer has not set a plan. - -=end _private - -=cut - -sub _plan_handled ($self) :method { - return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; -} - - -=item B + local $? = 0; # don't fail if $subtests happened to set $? nonzero - my $ok = $child->finalize; + $self->{Stack}->pop($chub); -When your child is done running tests, you must call C to clean up -and tell the parent your pass/fail status. + $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO}); -Calling C on a child with open children will C. + my $parent = $self->parent; + my $ctx = $parent->ctx; + my $trace = $ctx->trace; + delete $ctx->hub->meta(__PACKAGE__, {})->{child}; -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. + $chub->finalize($trace, 1) + if $ok + && $chub->count + && !$chub->no_ending + && !$chub->ended; -No attempt to call methods on a child after C is called is -guaranteed to succeed. + my $plan = $chub->plan || 0; + my $count = $chub->count; + my $failed = $chub->failed; + my $passed = $chub->is_passing; -Calling this on the root builder is a no-op. + my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan; + if ($count && $num_extra != 0) { + my $s = $plan == 1 ? '' : 's'; + $st_ctx->diag(<<"FAIL"); +Looks like you planned $plan test$s but ran $count. +FAIL + } -=cut + if ($failed) { + my $s = $failed == 1 ? '' : 's'; -sub finalize ($self) :method { + my $qualifier = $num_extra == 0 ? '' : ' run'; - return unless $self->parent; - if( $self->{Child_Name} ) { - $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); + $st_ctx->diag(<<"FAIL"); +Looks like you failed $failed test$s of $count$qualifier. +FAIL } - local $? = 0; # don't fail if $subtests happened to set $? nonzero - $self->_ending; + if (!$passed && !$failed && $count && !$num_extra) { + $st_ctx->diag(<<"FAIL"); +All assertions inside the subtest passed, but errors were encountered. +FAIL + } - # XXX This will only be necessary for TAP envelopes (we think) - #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); + $st_ctx->release; - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $ok = 1; # XXX maybe referenced in a child? - $self->parent->{Child_Name} = undef; - unless ($self->{Bailed_Out}) { - if ( $self->{Skip_All} ) { - $self->parent->skip($self->{Skip_All}, $self->name); + unless ($chub->bailed_out) { + my $plan = $chub->plan; + if ( $plan && $plan eq 'SKIP' ) { + $parent->skip($chub->skip_reason, $meta->{Name}); } - elsif ( not @{ $self->{Test_Results} } ) { - $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); + elsif ( !$chub->count ) { + $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} ); } else { - $self->parent->ok( $self->is_passing, $self->name ); + $parent->{subevents} = $meta->{subevents}; + $parent->{subtest_id} = $meta->{subtest_id}; + $parent->{subtest_buffered} = $meta->{subtest_buffered}; + $parent->ok( $chub->is_passing, $meta->{Name} ); } } - $? = $self->{Child_Error}; - delete $self->{Parent}; - return $self->is_passing; + $ctx->release; + return $chub->is_passing; } -sub _indent ($self, @args) :method { - if( @args) { - $self->{Indent} = shift @args; +sub subtest { + my $self = shift; + my ($name, $code, @args) = @_; + my $ctx = $self->ctx; + $ctx->throw("subtest()'s second argument must be a code ref") + unless $code && reftype($code) eq 'CODE'; + + $name ||= "Child of " . $self->name; + + $ctx->note("Subtest: $name"); + + my $child = $self->child($name); + + my $start_pid = $$; + my $st_ctx; + my ($ok, $err, $finished, $child_error); + T2_SUBTEST_WRAPPER: { + my $ctx = $self->ctx; + $st_ctx = $ctx->snapshot; + $ctx->release; + $ok = eval { local $Level = 1; $code->(@args); 1 }; + ($err, $child_error) = ($@, $?); + + # They might have done 'BEGIN { skip_all => "whatever" }' + if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { + $ok = undef; + $err = undef; + } + else { + $finished = 1; + } } - return $self->{Indent}; -} -=item B - - if ( my $parent = $builder->parent ) { - ... - } + if ($start_pid != $$ && !$INC{'Test/Sync/IPC.pm'}) { + warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; + exit 255; + } -Returns the parent C instance, if any. Only used with child -builders for nested TAP. + my $trace = $ctx->trace; -=cut + if (!$finished) { + if(my $bailed = $st_ctx->hub->bailed_out) { + my $chub = $child->{Hub}; + $self->{Stack}->pop($chub); + $ctx->bail($bailed->reason); + } + my $code = $st_ctx->hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } -sub parent ($self) :method { $self->{Parent} } + my $st_hub = $st_ctx->hub; + my $plan = $st_hub->plan; + my $count = $st_hub->count; -=item B + if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) { + $st_ctx->plan(0) unless defined $plan; + $st_ctx->diag('No tests run!'); + } - diag $builder->name; + $child->finalize($st_ctx->trace); -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". + $ctx->release; -=cut + die $err unless $ok; -sub name ($self) :method { $self->{Name} } + $? = $child_error if defined $child_error; -sub DESTROY ($self) :method { - 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); - } + return $st_hub->is_passing; } -=item B - - $Test->reset; - -Reinitializes the Test::Builder singleton to its original state. -Mostly useful for tests run in persistent environments where the same -test might be run multiple times in the same process. - -=cut +sub name { + my $self = shift; + my $ctx = $self->ctx; + release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name}; +} -our $Level; +sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my ($self, %params) = @_; -sub reset ($self) :method { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + Test2::API::test2_set_is_end(0); # 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; - $self->is_passing(1); - $self->{Ending} = 0; - $self->{Have_Plan} = 0; - $self->{No_Plan} = 0; - $self->{Have_Output_Plan} = 0; - $self->{Done_Testing} = 0; - $self->{Original_Pid} = $$; - $self->{Child_Name} = undef; - $self->{Indent} ||= ''; - - $self->{Curr_Test} = 0; - $self->{Test_Results} = &share( [] ); - - $self->{Exported_To} = undef; - $self->{Expected_Tests} = 0; - $self->{Skip_All} = 0; - - $self->{Use_Nums} = 1; - - $self->{No_Header} = 0; - $self->{No_Ending} = 0; + my $ctx = $self->ctx; + unless ($params{singleton}) { + $ctx->hub->reset_state(); + $ctx->hub->set_pid($$); + $ctx->hub->set_tid(get_tid); + } - $self->{Todo} = undef; - $self->{Todo_Stack} = []; - $self->{Start_Todo} = 0; - $self->{Opened_Testhandles} = 0; + my $meta = $ctx->hub->meta(__PACKAGE__, {}); + %$meta = ( + Name => $0, + Ending => 0, + Done_Testing => undef, + Skip_All => 0, + Test_Results => [], + ); - $self->_share_keys; - $self->_dup_stdhandles; + $self->{Exported_To} = undef; - return; -} + $self->{Orig_Handles} ||= do { + my $format = $ctx->hub->format; + my $out; + if ($format && $format->isa('Test2::Formatter::TAP')) { + $out = $format->handles; + } + $out ? [@$out] : []; + }; + $self->use_numbers(1); + $self->no_header(0); + $self->no_ending(0); + $self->reset_outputs; -# 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. + $ctx->release; -sub _share_keys ($self) :method { - share( $self->{Curr_Test} ); return; } -=back - -=head2 Setting up tests - -These methods are for setting up tests and declaring how many there -are. You usually only want to call one of these methods. - -=over 4 - -=item B - - $Test->plan('no_plan'); - $Test->plan( skip_all => $reason ); - $Test->plan( tests => $num_tests ); - -A convenient way to set up your tests. Call this and Test::Builder -will print the appropriate headers and take the appropriate actions. - -If you call C, don't call any of the other methods below. - -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 $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 - -=cut - my %plan_cmds = ( - no_plan => \&no_plan, - skip_all => \&skip_all, - tests => \&_plan_tests, + no_plan => \&no_plan, + skip_all => \&skip_all, + tests => \&_plan_tests, ); -sub plan ( $self, $cmd?, $arg? ) :method { +sub plan { + my( $self, $cmd, $arg ) = @_; return unless $cmd; - local $Level = $Level + 1; + my $ctx = $self->ctx; + my $hub = $ctx->hub; - $self->croak("You tried to plan twice") if $self->{Have_Plan}; + $ctx->throw("You tried to plan twice") if $hub->plan; + + local $Level = $Level + 1; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; @@ -524,231 +436,159 @@ sub plan ( $self, $cmd?, $arg? ) :method { } else { my @args = grep { defined } ( $cmd, $arg ); - $self->croak("plan() doesn't understand @args"); + $ctx->throw("plan() doesn't understand @args"); } - return 1; + release $ctx, 1; } -sub _plan_tests ($self, $arg?) :method { +sub _plan_tests { + my($self, $arg) = @_; + + my $ctx = $self->ctx; - if (defined $arg and $arg) { + if($arg) { local $Level = $Level + 1; - return $self->expected_tests($arg); + $self->expected_tests($arg); } elsif( !defined $arg ) { - $self->croak("Got an undefined number of tests"); + $ctx->throw("Got an undefined number of tests"); } else { - $self->croak("You said to run 0 tests"); + $ctx->throw("You said to run 0 tests"); } - return; + $ctx->release; } -=item B - - my $max = $Test->expected_tests; - $Test->expected_tests($max); -Gets/sets the number of tests we expect this test to run and prints out -the appropriate headers. +sub expected_tests { + my $self = shift; + my($max) = @_; -=cut + my $ctx = $self->ctx; -sub expected_tests ($self, int $max=0) :method { - if ($max) { + if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; - $self->{Expected_Tests} = $max; - $self->{Have_Plan} = 1; - - $self->_output_plan($max) unless $self->no_header; + $ctx->plan($max); } - return $self->{Expected_Tests}; -} -=item B + my $hub = $ctx->hub; - $Test->no_plan; + $ctx->release; -Declares that this test will run an indeterminate number of tests. + my $plan = $hub->plan; + return 0 unless $plan; + return 0 if $plan =~ m/\D/; + return $plan; +} -=cut -sub no_plan ($self, $arg?) :method { - $self->carp("no_plan takes no arguments") if $arg; - $self->{No_Plan} = 1; - $self->{Have_Plan} = 1; - return 1; -} +sub no_plan { + my($self, $arg) = @_; -=begin private + my $ctx = $self->ctx; + + if (defined $ctx->hub->plan) { + warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future."; + $ctx->release; + return; + } -=item B<_output_plan> + $ctx->alert("no_plan takes no arguments") if $arg; - $tb->_output_plan($max); - $tb->_output_plan($max, $directive); - $tb->_output_plan($max, $directive => $reason); + $ctx->hub->plan('NO PLAN'); -Handles displaying the test plan. + release $ctx, 1; +} -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"); +sub done_testing { + my($self, $num_tests) = @_; -It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already -output. + my $ctx = $self->ctx; -=end private + my $meta = $ctx->hub->meta(__PACKAGE__, {}); -=cut + if ($meta->{Done_Testing}) { + my ($file, $line) = @{$meta->{Done_Testing}}[1,2]; + local $ctx->hub->{ended}; # OMG This is awful. + $self->ok(0, "done_testing() was already called at $file line $line"); + $ctx->release; + return; + } + $meta->{Done_Testing} = [$ctx->trace->call]; -sub _output_plan ($self, int $max, str $directive='', str $reason='') :method { + my $plan = $ctx->hub->plan; + my $count = $ctx->hub->count; - $self->carp("The plan was already output") if $self->{Have_Output_Plan}; + # If done_testing() specified the number of tests, shut off no_plan + if( defined $num_tests ) { + $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN'; + } + elsif ($count && defined $num_tests && $count != $num_tests) { + $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests"); + } + else { + $num_tests = $self->current_test; + } - my str $plan = "1..$max"; - $plan .= " # $directive" if $directive; - $plan .= " $reason" if $reason; + if( $self->expected_tests && $num_tests != $self->expected_tests ) { + $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". + "but done_testing() expects $num_tests"); + } - $self->_print("$plan\n"); + $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN'; - $self->{Have_Output_Plan} = 1; + $ctx->hub->finalize($ctx->trace, 1); - return; + release $ctx, 1; } -=item B +sub has_plan { + my $self = shift; - $Test->done_testing(); - $Test->done_testing($num_tests); + my $ctx = $self->ctx; + my $plan = $ctx->hub->plan; + $ctx->release; -Declares that you are done testing, no more tests will be run after this point. + return( $plan ) if $plan && $plan !~ m/\D/; + return('no_plan') if $plan && $plan eq 'NO PLAN'; + return(undef); +} -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. +sub skip_all { + my( $self, $reason ) = @_; -If C is called twice, the second call will issue a -failing test. + my $ctx = $self->ctx; -If C<$num_tests> is omitted, the number of tests run will be used, like -no_plan. + $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1; -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 ($self, $num_tests=0) :method { - - # If done_testing() specified the number of tests, shut off no_plan. - if( $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; + # Work around old perl bug + if ($] < 5.020000) { + my $begin = 0; + my $level = 0; + while (my @call = caller($level++)) { + last unless @call && $call[0]; + next unless $call[3] =~ m/::BEGIN$/; + $begin++; + last; + } + # HACK! + die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent}; } - $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 ($self) :method { - - 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 ( $self, str $reason='' ) :method { - - $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); + $ctx->plan(0, SKIP => $reason); } -=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 ($self, $pack?) :method { +sub exported_to { + my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; @@ -756,170 +596,130 @@ sub exported_to ($self, $pack?) :method { 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 ) = @_; -sub ok ( $self, $test, $name? ) :method { + my $ctx = $self->ctx; - 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 ); + no warnings qw/uninitialized numeric/; + $name = "$name" if defined $name; - $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; + # Profiling showed that the regex here was a huge time waster, doing the + # numeric addition first cuts our profile time from ~300ms to ~50ms + $self->diag(<<" ERR") if 0 + $name && $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( {} ); + ERR + use warnings qw/uninitialized numeric/; + + my $trace = $ctx->{trace}; + my $hub = $ctx->{hub}; + + my $result = { + ok => $test, + actual_ok => $test, + reason => '', + type => '', + (name => defined($name) ? $name : ''), + }; - unless($test) { - $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); - } - else { - @$result{ 'ok', 'actual_ok' } = ( 1, $test ); - } + $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result; - $out .= "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; + my $orig_name = $name; - if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; - $result->{name} = $name; - } - else { - $result->{name} = ''; + my @attrs; + my $subevents = delete $self->{subevents}; + my $subtest_id = delete $self->{subtest_id}; + my $subtest_buffered = delete $self->{subtest_buffered}; + my $epkg = 'Test2::Event::Ok'; + if ($subevents) { + $epkg = 'Test2::Event::Subtest'; + push @attrs => (subevents => $subevents, subtest_id => $subtest_id, buffered => $subtest_buffered); } - if( $self->in_todo ) { - $out .= " # TODO $todo"; - $result->{reason} = $todo; - $result->{type} = 'todo'; - } - else { - $result->{reason} = ''; - $result->{type} = ''; - } + my $e = bless { + trace => bless( {%$trace}, 'Test2::Util::Trace'), + pass => $test, + name => $name, + _meta => {'Test::Builder' => $result}, + effective_pass => $test, + @attrs, + }, $epkg; + $hub->send($e); - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; - $out .= "\n"; + $self->_ok_debug($trace, $orig_name) unless($test); - $self->_print($out); + $ctx->release; + return $test; +} - unless($test) { - my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; - $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; +sub _ok_debug { + my $self = shift; + my ($trace, $orig_name) = @_; - 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]); - } - } + my $is_todo = defined($self->todo); - $self->is_passing(0) unless $test || $self->in_todo; + my $msg = $is_todo ? "Failed (TODO)" : "Failed"; - # Check that we haven't violated the plan - $self->_check_is_passing_plan(); + my $dfh = $self->_diag_fh; + print $dfh "\n" if $ENV{HARNESS_ACTIVE} && $dfh; - return $test ? 1 : 0; + my (undef, $file, $line) = $trace->call; + if (defined $orig_name) { + $self->diag(qq[ $msg test '$orig_name'\n]); + $self->diag(qq[ at $file line $line.\n]); + } + else { + $self->diag(qq[ $msg test at $file line $line.\n]); + } } - -# Check that we haven't yet violated the plan and set -# is_passing() accordingly -sub _check_is_passing_plan ($self) :method { - 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 _diag_fh { + my $self = shift; + local $Level = $Level + 1; + return $self->in_todo ? $self->todo_output : $self->failure_output; } - sub _unoverload { - my $self = shift; - my $type = shift; - - $self->_try(sub { require overload; }, die_on_fail => 1); + my ($self, $type, $thing) = @_; - foreach my $thing (@_) { - if( $self->_is_object($$thing) ) { - if( my $string_meth = overload::Method( $$thing, $type ) ) { - $$thing = $$thing->$string_meth(); - } - } + return unless ref $$thing; + return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') }); + { + local ($!, $@); + require overload; } - - return; -} - -sub _is_object ( $self, $thing ) :method { - return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; + my $string_meth = overload::Method( $$thing, $type ) || return; + $$thing = $$thing->$string_meth(); } sub _unoverload_str { my $self = shift; - return $self->_unoverload( q[""], @_ ); + $self->_unoverload( q[""], $_ ) for @_; } sub _unoverload_num { my $self = shift; - $self->_unoverload( '0+', @_ ); + $self->_unoverload( '0+', $_ ) for @_; 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 ($self, $val) :method { +sub _is_dualvar { + my( $self, $val ) = @_; + # Objects are not dualvars. return 0 if ref $val; @@ -928,27 +728,12 @@ sub _is_dualvar ($self, $val) :method { 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. +sub is_eq { + my( $self, $got, $expect, $name ) = @_; -=cut + my $ctx = $self->ctx; -sub is_eq ( $self, $got?, $expect?, $name?) :method { local $Level = $Level + 1; if( !defined $got || !defined $expect ) { @@ -957,13 +742,17 @@ sub is_eq ( $self, $got?, $expect?, $name?) :method { $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, 'eq', $expect, $name ); + release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name ); } -sub is_num ($self, $got, $expect, $name?) :method { + +sub is_num { + my( $self, $got, $expect, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { @@ -972,13 +761,16 @@ sub is_num ($self, $got, $expect, $name?) :method { $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, '==', $expect, $name ); + release $ctx, $self->cmp_ok( $got, '==', $expect, $name ); } -sub _diag_fmt ($self, $type, $val?) :method { + +sub _diag_fmt { + my( $self, $type, $val ) = @_; if( defined $$val ) { if( $type eq 'eq' or $type eq 'ne' ) { @@ -997,7 +789,9 @@ sub _diag_fmt ($self, $type, $val?) :method { return; } -sub _is_diag ( $self, $got, $type, $expect ) :method { + +sub _is_diag { + my( $self, $got, $type, $expect ) = @_; $self->_diag_fmt( $type, $_ ) for \$got, \$expect; @@ -1009,7 +803,8 @@ DIAGNOSTIC } -sub _isnt_diag ( $self, $got, $type ) :method { +sub _isnt_diag { + my( $self, $got, $type ) = @_; $self->_diag_fmt( $type, \$got ); @@ -1020,23 +815,10 @@ sub _isnt_diag ( $self, $got, $type ) :method { 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 ( $self, $got?, $dont_expect?, $name?) :method { +sub isnt_eq { + my( $self, $got, $dont_expect, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { @@ -1045,13 +827,16 @@ sub isnt_eq ( $self, $got?, $dont_expect?, $name?) :method { $self->ok( $test, $name ); $self->_isnt_diag( $got, 'ne' ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); + release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } -sub isnt_num ( $self, $got, $dont_expect, str $name) :method { +sub isnt_num { + my( $self, $got, $dont_expect, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { @@ -1060,60 +845,44 @@ sub isnt_num ( $self, $got, $dont_expect, str $name) :method { $self->ok( $test, $name ); $self->_isnt_diag( $got, '!=' ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, '!=', $dont_expect, $name ); + release $ctx, $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 ( $self, $thing, $regex, $name?) :method { +sub like { + my( $self, $thing, $regex, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '=~', $name ); -} - -sub unlike ( $self, $thing, $regex, $name?) :method { - local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '!~', $name ); + release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name ); } -=item B - - $Test->cmp_ok($thing, $type, $that, $name); +sub unlike { + my( $self, $thing, $regex, $name ) = @_; + my $ctx = $self->ctx; -Works just like L's C. + local $Level = $Level + 1; - $Test->cmp_ok($big_num, '!=', $other_big_num); + release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name ); +} -=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 ( $self, $got, $type, $expect, $name? ) :method { +sub cmp_ok { + my( $self, $got, $type, $expect, $name ) = @_; + my $ctx = $self->ctx; if ($cmp_ok_bl{$type}) { - $self->croak("$type is not a valid comparison operator in cmp_ok()"); + $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); } my ($test, $succ); @@ -1123,7 +892,7 @@ sub cmp_ok ( $self, $got, $type, $expect, $name? ) :method { local( $@, $!, $SIG{__DIE__} ); # isolate eval - my($pack, $file, $line) = $self->caller(); + my($pack, $file, $line) = $ctx->trace->call(); # This is so that warnings come out at the caller's level $succ = eval qq[ @@ -1157,13 +926,26 @@ END $self->_is_diag( $got, $type, $expect ); } elsif( $type =~ /^(ne|!=)$/ ) { - $self->_isnt_diag( $got, $type ); + no warnings; + my $eq = ($got eq $expect || $got == $expect) + && ( + (defined($got) xor defined($expect)) + || (length($got) != length($expect)) + ); + use warnings; + + if ($eq) { + $self->_cmp_diag( $got, $type, $expect ); + } + else { + $self->_isnt_diag( $got, $type ); + } } else { $self->_cmp_diag( $got, $type, $expect ); } } - return $ok; + return release $ctx, $ok; } sub _cmp_diag { @@ -1180,298 +962,1098 @@ sub _cmp_diag { DIAGNOSTIC } -sub _caller_context ($self) :method { +sub _caller_context { + my $self = shift; + my( $pack, $file, $line ) = $self->caller(1); + my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; + return $code; } -=back - - -=head2 Other Testing Methods - -These are methods which are used in the course of writing a test but are not themselves tests. - -=over 4 - -=item B - - $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 ) = @_; -sub BAIL_OUT ( $self, str $reason ) :method { + my $ctx = $self->ctx; $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; + $ctx->bail($reason); } -=for deprecated -BAIL_OUT() used to be BAILOUT() - -=cut { no warnings 'once'; *BAILOUT = \&BAIL_OUT; } -=item B +sub skip { + my( $self, $why, $name ) = @_; + $why ||= ''; + $name = '' unless defined $name; + $self->_unoverload_str( \$why ); - $Test->skip; - $Test->skip($why); + my $ctx = $self->ctx; -Skips the current test, reporting C<$why>. + $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { + 'ok' => 1, + actual_ok => 1, + name => $name, + type => 'skip', + reason => $why, + }; -=cut + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $name =~ s{\n}{\n# }sg; + $why =~ s{\n}{\n# }sg; -sub skip ( $self, str $why='', $name? ) :method { - $self->_unoverload_str( \$why ); + my $tctx = $ctx->snapshot; + $tctx->skip('', $why); - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; + return release $ctx, 1; +} - $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"; +sub todo_skip { + my( $self, $why ) = @_; + $why ||= ''; - $self->_print($out); + my $ctx = $self->ctx; - return 1; + $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + }; + + $why =~ s{\n}{\n# }sg; + my $tctx = $ctx->snapshot; + $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0); + + return release $ctx, 1; } -=item B - $Test->todo_skip; - $Test->todo_skip($why); +sub maybe_regex { + my( $self, $regex ) = @_; + my $usable_regex = undef; -Like C, only it will declare the test as failing and TODO. Similar -to + return $usable_regex unless defined $regex; - print "not ok $tnum # TODO $why\n"; + my( $re, $opts ); -=cut + # Check for qr/foo/ + if( _is_qr($regex) ) { + $usable_regex = $regex; + } + # Check for '/foo/' or 'm,foo,' + elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or + ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx + ) + { + $usable_regex = length $opts ? "(?$opts)$re" : $re; + } + + return $usable_regex; +} + +sub _is_qr { + my $regex = shift; + + # is_regexp() checks for regexes in a robust manner, say if they're + # blessed. + return re::is_regexp($regex) if defined &re::is_regexp; + return ref $regex eq 'Regexp'; +} + +sub _regex_ok { + my( $self, $thing, $regex, $cmp, $name ) = @_; -sub todo_skip ( $self, str $why='') :method { + 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; + } - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; + { + my $test; + my $context = $self->_caller_context; - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( { - 'ok' => 1, - actual_ok => 0, - name => '', - type => 'todo_skip', - reason => $why, + ## 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}; } - ); - my $out = "not ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # TODO & SKIP $why\n"; + $test = !$test if $cmp eq '!~'; - $self->_print($out); + local $Level = $Level + 1; + $ok = $self->ok( $test, $name ); + } - return 1; + 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; } -=begin _unimplemented -=item B +sub is_fh { + my $self = shift; + my $maybe_fh = shift; + return 0 unless defined $maybe_fh; - $Test->skip_rest; - $Test->skip_rest($reason); + return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob -Like C, only it skips all the rest of the tests you plan to run -and terminates the test. + return eval { $maybe_fh->isa("IO::Handle") } || + eval { tied($maybe_fh)->can('TIEHANDLE') }; +} -If you're running under C, it skips once and terminates the -test. -=end _unimplemented +sub level { + my( $self, $level ) = @_; -=back + if( defined $level ) { + $Level = $level; + } + return $Level; +} -=head2 Test building utility methods +sub use_numbers { + my( $self, $use_nums ) = @_; -These methods are useful when writing your own test methods. + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) { + warn "The current formatter does not support 'use_numbers'" if $format; + return release $ctx, 0; + } -=over 4 + $format->set_no_numbers(!$use_nums) if defined $use_nums; -=item B + return release $ctx, $format->no_numbers ? 0 : 1; +} - $Test->maybe_regex(qr/$regex/); - $Test->maybe_regex('/$regex/'); +BEGIN { + for my $method (qw(no_header no_diag)) { + my $set = "set_$method"; + my $code = sub { + my( $self, $no ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + unless ($format && $format->can($set)) { + warn "The current formatter does not support '$method'" if $format; + $ctx->release; + return + } -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. + $format->$set($no) if defined $no; -Convenience method for building testing functions that take regular -expressions as arguments. + return release $ctx, $format->$method ? 1 : 0; + }; -Takes a quoted regular expression produced by C, or a string -representing a regular expression. + no strict 'refs'; ## no critic + *$method = $code; + } +} -Returns a Perl value which may be used instead of the corresponding -regular expression, or C if its argument is not recognised. +sub no_ending { + my( $self, $no ) = @_; -For example, a version of C, sans the useful diagnostic messages, -could be written as: + my $ctx = $self->ctx; - 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); - } + $ctx->hub->set_no_ending($no) if defined $no; -=cut + return release $ctx, $ctx->hub->no_ending; +} -sub maybe_regex ( $self, $regex ) :method { - my $usable_regex = undef; +sub diag { + my $self = shift; + return unless @_; - return $usable_regex unless defined $regex; + my $ctx = $self->ctx; + $ctx->diag(join '' => map {defined($_) ? $_ : 'undef'} @_); + $ctx->release; + return 0; +} - my( $re, $opts ); - # Check for qr/foo/ - if( _is_qr($regex) ) { - $usable_regex = $regex; +sub note { + my $self = shift; + return unless @_; + + my $ctx = $self->ctx; + $ctx->note(join '' => map {defined($_) ? $_ : 'undef'} @_); + $ctx->release; + return 0; +} + + +sub explain { + my $self = shift; + + local ($@, $!); + 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; + } + : $_ + } @_; +} + + +sub output { + my( $self, $fh ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test2::Formatter::TAP'); + + $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh) + if defined $fh; + + return $format->handles->[Test2::Formatter::TAP::OUT_STD()]; +} + +sub failure_output { + my( $self, $fh ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test2::Formatter::TAP'); + + $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh) + if defined $fh; + + return $format->handles->[Test2::Formatter::TAP::OUT_ERR()]; +} + +sub todo_output { + my( $self, $fh ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test::Builder::Formatter'); + + $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh) + if defined $fh; + + return $format->handles->[Test::Builder::Formatter::OUT_TODO()]; +} + +sub _new_fh { + my $self = shift; + my($file_or_fh) = shift; + + my $fh; + if( $self->is_fh($file_or_fh) ) { + $fh = $file_or_fh; } - # 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; + 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 $usable_regex; + return $fh; } -sub _is_qr ($regex) { - # 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 _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; + + return; } -sub _regex_ok ( $self, $thing, $regex, $cmp, $name) :method { - 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; +sub reset_outputs { + my $self = shift; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test2::Formatter::TAP'); + $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles}; + + return; +} + + +sub carp { + my $self = shift; + my $ctx = $self->ctx; + $ctx->alert(join "", @_); + $ctx->release; +} + +sub croak { + my $self = shift; + my $ctx = $self->ctx; + $ctx->throw(join "", @_); + $ctx->release; +} + + +sub current_test { + my( $self, $num ) = @_; + + my $ctx = $self->ctx; + my $hub = $ctx->hub; + + if( defined $num ) { + $hub->set_count($num); + + # If the test counter is being pushed forward fill in the details. + my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + if( $num > @$test_results ) { + my $start = @$test_results ? @$test_results : 0; + for( $start .. $num - 1 ) { + $test_results->[$_] = { + '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 release $ctx, $hub->count; +} - { - my $test; - my $context = $self->_caller_context; - { - ## no critic (BuiltinFunctions::ProhibitStringyEval) +sub is_passing { + my $self = shift; + + my $ctx = $self->ctx; + my $hub = $ctx->hub; + + if( @_ ) { + my ($bool) = @_; + $hub->set_failed(0) if $bool; + $hub->is_passing($bool); + } + + return release $ctx, $hub->is_passing; +} + + +sub summary { + my($self) = shift; + + my $ctx = $self->ctx; + my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + $ctx->release; + return map { $_->{'ok'} } @$data; +} + + +sub details { + my $self = shift; + my $ctx = $self->ctx; + my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + $ctx->release; + return @$data; +} + + +sub find_TODO { + my( $self, $pack, $set, $new_value ) = @_; + + my $ctx = $self->ctx; + + $pack ||= $ctx->trace->package || $self->exported_to; + $ctx->release; + + return unless $pack; + + no strict 'refs'; ## no critic + no warnings 'once'; + my $old_value = ${ $pack . '::TODO' }; + $set and ${ $pack . '::TODO' } = $new_value; + return $old_value; +} + +sub todo { + my( $self, $pack ) = @_; + + local $Level = $Level + 1; + my $ctx = $self->ctx; + $ctx->release; + + my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; + return $meta->[-1]->[1] if $meta && @$meta; + + $pack ||= $ctx->trace->package; + + return unless $pack; + + no strict 'refs'; ## no critic + no warnings 'once'; + return ${ $pack . '::TODO' }; +} + +sub in_todo { + my $self = shift; + + local $Level = $Level + 1; + my $ctx = $self->ctx; + $ctx->release; + + my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; + return 1 if $meta && @$meta; + + my $pack = $ctx->trace->package || return 0; + + no strict 'refs'; ## no critic + no warnings 'once'; + my $todo = ${ $pack . '::TODO' }; + + return 0 unless defined $todo; + return 0 if "$todo" eq ''; + return 1; +} + +sub todo_start { + my $self = shift; + my $message = @_ ? shift : ''; + + my $ctx = $self->ctx; + + my $hub = $ctx->hub; + my $filter = $hub->pre_filter(sub { + my ($active_hub, $e) = @_; + + # Turn a diag into a todo diag + return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; + + # Set todo on ok's + if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) { + $e->set_todo($message); + $e->set_effective_pass(1); + + if (my $result = $e->get_meta(__PACKAGE__)) { + $result->{reason} ||= $message; + $result->{type} ||= 'todo'; + $result->{ok} = 1; + } + } + + return $e; + }, inherit => 1); + + push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message]; + + $ctx->release; + + return; +} + +sub todo_end { + my $self = shift; + + my $ctx = $self->ctx; + + my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}}; + + $ctx->throw('todo_end() called without todo_start()') unless $set; + + $ctx->hub->pre_unfilter($set->[0]); + + $ctx->release; + + return; +} + + +sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my( $self ) = @_; + + my $ctx = $self->ctx; + + my $trace = $ctx->trace; + $ctx->release; + return wantarray ? $trace->call : $trace->package; +} + + +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; +} + +sub _ending { + my $self = shift; + my ($ctx, $real_exit_code, $new) = @_; + + unless ($ctx) { + my $octx = $self->ctx; + $ctx = $octx->snapshot; + $octx->release; + } + + return if $ctx->hub->no_ending; + return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++; + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + return unless $self->{Original_Pid} == $$; + + my $hub = $ctx->hub; + return if $hub->bailed_out; + + my $plan = $hub->plan; + my $count = $hub->count; + my $failed = $hub->failed; + my $passed = $hub->is_passing; + return unless $plan || $count || $failed; + + # Ran tests but never declared a plan or hit done_testing + if( !$hub->plan and $hub->count ) { + $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 $count. +FAIL + $$new ||= $real_exit_code; + return; + } + + # But if the tests ran, handle exit code. + if($failed > 0) { + my $exit_code = $failed <= 254 ? $failed : 254; + $$new ||= $exit_code; + return; + } + + $$new ||= 254; + return; + } + + if ($real_exit_code && !$count) { + $self->diag("Looks like your test exited with $real_exit_code before it could output anything."); + $$new ||= $real_exit_code; + return; + } + + return if $plan && "$plan" eq 'SKIP'; + + if (!$count) { + $self->diag('No tests run!'); + $$new ||= 255; + return; + } + + if ($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code just after $count. +FAIL + $$new ||= $real_exit_code; + return; + } + + if ($plan eq 'NO PLAN') { + $ctx->plan( $count ); + $plan = $hub->plan; + } + + # Figure out if we passed or failed and print helpful messages. + my $num_extra = $count - $plan; + + if ($num_extra != 0) { + my $s = $plan == 1 ? '' : 's'; + $self->diag(<<"FAIL"); +Looks like you planned $plan test$s but ran $count. +FAIL + } + + if ($failed) { + my $s = $failed == 1 ? '' : 's'; + + my $qualifier = $num_extra == 0 ? '' : ' run'; + + $self->diag(<<"FAIL"); +Looks like you failed $failed test$s of $count$qualifier. +FAIL + } + + if (!$passed && !$failed && $count && !$num_extra) { + $ctx->diag(<<"FAIL"); +All assertions passed, but errors were encountered. +FAIL + } + + my $exit_code = 0; + if ($failed) { + $exit_code = $failed <= 254 ? $failed : 254; + } + elsif ($num_extra != 0) { + $exit_code = 255; + } + elsif (!$passed) { + $exit_code = 255; + } + + $$new ||= $exit_code; + return; +} + +# Some things used this even though it was private... I am looking at you +# Test::Builder::Prefix... +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( $\, $", $, ) = ( undef, ' ', '' ); + print $fh $msg; + + return 0; +} + +# This is used by Test::SharedFork to turn on IPC after the fact. Not +# documenting because I do not want it used. The method name is borrowed from +# Test::Builder 2 +# Once Test2 stuff goes stable this method will be removed and Test::SharedFork +# will be made smarter. +sub coordinate_forks { + my $self = shift; + + { + local ($@, $!); + require Test2::IPC; + } + Test2::IPC->import; + Test2::API::test2_ipc_enable_polling(); + my $ipc = Test2::IPC::apply_ipc($self->{Stack}); + $ipc->set_no_fatal(1); + Test2::API::test2_no_wait(1); + Test2::API::test2_ipc_enable_shm(); +} + +1; + +__END__ + +=head1 NAME + +Test::Builder - Backend for building test libraries + +=head1 SYNOPSIS + + package My::Test::Module; + use base 'Test::Builder::Module'; + + my $CLASS = __PACKAGE__; + + sub ok { + my($test, $name) = @_; + my $tb = $CLASS->builder; + + $tb->ok($test, $name); + } + + +=head1 DESCRIPTION + +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. + +=head2 Construction + +=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. + +=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 by B Test::Builder objects, even ones created using this method. +Also, the method name may change in the future. + +=item B + + $builder->subtest($name, \&subtests, @args); + +See documentation of C in Test::More. + +C also, and optionally, accepts arguments which will be passed to the +subtests reference. + +=item B + + diag $builder->name; + +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". + +=item B + + $Test->reset; + +Reinitializes the Test::Builder singleton to its original state. +Mostly useful for tests run in persistent environments where the same +test might be run multiple times in the same process. + +=back + +=head2 Setting up tests + +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. + +=over 4 + +=item B + + $Test->plan('no_plan'); + $Test->plan( skip_all => $reason ); + $Test->plan( tests => $num_tests ); + +A convenient way to set up your tests. Call this and Test::Builder +will print the appropriate headers and take the appropriate actions. + +If you call C, don't call any of the other methods below. + +=item B + + my $max = $Test->expected_tests; + $Test->expected_tests($max); + +Gets/sets the number of tests we expect this test to run and prints out +the appropriate headers. + + +=item B + + $Test->no_plan; + +Declares that this test will run an indeterminate number of tests. + + +=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); + + +=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). + +=item B + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given C<$reason>. Exits immediately with 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. + +=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. + +=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. + +=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. + +=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>. + +=item B + + $Test->cmp_ok($thing, $type, $that, $name); + +Works just like L's C. + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=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. + +=for deprecated +BAIL_OUT() used to be BAILOUT() + +=item B + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting C<$why>. + +=item B - local( $@, $!, $SIG{__DIE__} ); # isolate eval + $Test->todo_skip; + $Test->todo_skip($why); - # No point in issuing an uninit warning, they'll see it in the diagnostics - no warnings 'uninitialized'; +Like C, only it will declare the test as failing and TODO. Similar +to - $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; - } + print "not ok $tnum # TODO $why\n"; - $test = !$test if $cmp eq '!~'; +=begin _unimplemented - local $Level = $Level + 1; - $ok = $self->ok( $test, $name ); - } +=item B - unless($ok) { - $thing = defined $thing ? "'$thing'" : 'undef'; - my $match = $cmp eq '=~' ? "doesn't match" : "matches"; + $Test->skip_rest; + $Test->skip_rest($reason); - local $Level = $Level + 1; - $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); - %s - %13s '%s' -DIAGNOSTIC +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. - return $ok; -} +=end _unimplemented -# I'm not ready to publish this. It doesn't deal with array return -# values from the code or context. +=back -=begin private -=item B<_try> +=head2 Test building utility methods - my $return_from_code = $Test->try(sub { code }); - my($return_from_code, $error) = $Test->try(sub { code }); +These methods are useful when writing your own test methods. -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. +=over 4 -C<$error> is what would normally be in C<$@>. +=item B -It is suggested you use this in place of eval BLOCK. + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); -=cut +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. -sub _try ( $self, $code, %opts ) :method { - 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 = $@; - } +Convenience method for building testing functions that take regular +expressions as arguments. - die $error if $error and $opts{die_on_fail}; +Takes a quoted regular expression produced by C, or a string +representing a regular expression. - return wantarray ? ( $return, $error ) : $return; -} +Returns a Perl value which may be used instead of the corresponding +regular expression, or C if its argument is not recognized. + +For example, a version of C, sans the useful diagnostic messages, +could be written as: -=end private + 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); + } =item B @@ -1482,15 +2064,6 @@ Determines if the given C<$thing> can be used as a filehandle. =cut -sub is_fh ($self, $maybe_fh?) :method { - return 0 unless defined $maybe_fh; - - return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref - return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob - - return eval { $maybe_fh->isa("IO::Handle") } || - eval { tied($maybe_fh)->can('TIEHANDLE') }; -} =back @@ -1521,15 +2094,6 @@ localized: 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 ($self, int $level=0) :method { - if ( $level ) { - $Level = $level; - } - return $Level; -} - =item B $Test->use_numbers($on_or_off); @@ -1551,16 +2115,6 @@ when threads or forking is involved. Defaults to on. -=cut - -sub use_numbers ( $self, $use_nums? ) :method { - - if( defined $use_nums ) { - $self->{Use_Nums} = $use_nums; - } - return $self->{Use_Nums}; -} - =item B $Test->no_diag($no_diag); @@ -1583,23 +2137,6 @@ If this is true, none of that will be done. 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 ($self, $no?) :method { - - if( defined $no ) { - $self->{$attribute} = $no; - } - return $self->{$attribute}; - }; - - no strict 'refs'; ## no critic - *{ __PACKAGE__ . '::' . $method } = $code; -} - =back =head2 Output @@ -1635,14 +2172,6 @@ a failing test (C) it "passes through" the failure. =for blame transfer Mark Fowler -=cut - -sub diag { - my $self = shift; - - $self->_print_comment( $self->_diag_fh, @_ ); -} - =item B $Test->note(@msgs); @@ -1650,40 +2179,6 @@ sub diag { 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 ($self) :method { - local $Level = $Level + 1; - return $self->in_todo ? $self->todo_output : $self->failure_output; -} - -sub _print_comment ( $self, $fh, @msgs ) :method { - - 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); @@ -1697,63 +2192,6 @@ or is_deeply($have, $want) || note explain $have; -=cut - -sub explain { - my $self = shift; - - return map { - ref $_ - ? do { - $self->_try(sub { require Data::Dumper }, die_on_fail => 1); - - my $dumper = Data::Dumper->new( [$_] ); - $dumper->Indent(1)->Terse(1); - $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); - $dumper->Dump; - } - : $_ - } @_; -} - -=begin _private - -=item B<_print> - - $Test->_print(@msgs); - -Prints to the C filehandle. - -=end _private - -=cut - -sub _print { - my $self = shift; - return $self->_print_to_fh( $self->output, @_ ); -} - -sub _print_to_fh ( $self, $fh, @msgs ) :method { - - # Prevent printing headers when only compiling. Mostly for when - # tests are deparsed with B::Deparse - return if $^C; - - my $msg = join '', @msgs; - my $indent = $self->_indent; - - local( $\, $", $, ) = ( undef, ' ', '' ); - - # Escape each line after the first with a # so we don't - # confuse Test::Harness. - $msg =~ s{\n(?!\z)}{\n$indent# }sg; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\z/; - - return print $fh $indent, $msg; -} - =item B =item B @@ -1765,140 +2203,25 @@ sub _print_to_fh ( $self, $fh, @msgs ) :method { $Test->output($filename); $Test->output(\$scalar); -These methods control where Test::Builder will print its output. -They take either an open C<$filehandle>, a C<$filename> to open and write to -or a C<$scalar> reference to append to. It will always return a C<$filehandle>. - -B is where normal "ok/not ok" test output goes. - -Defaults to STDOUT. - -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. - -Defaults to STDERR. - -C is used instead of C for the -diagnostics of a failing TODO test. These will not be seen by the -user. - -Defaults to STDOUT. - -=cut - -sub output ( $self, $fh? ) :method { - - if( defined $fh ) { - $self->{Out_FH} = $self->_new_fh($fh); - } - return $self->{Out_FH}; -} - -sub failure_output ( $self, $fh? ) :method { - - if( defined $fh ) { - $self->{Fail_FH} = $self->_new_fh($fh); - } - return $self->{Fail_FH}; -} - -sub todo_output ( $self, $fh? ) :method { - if( defined $fh ) { - $self->{Todo_FH} = $self->_new_fh($fh); - } - return $self->{Todo_FH}; -} - -sub _new_fh ($self, $file_or_fh) :method { - my $fh; - if( $self->is_fh($file_or_fh) ) { - $fh = $file_or_fh; - } - elsif( ref $file_or_fh eq 'SCALAR' ) { - # Scalar refs as filehandles was added in 5.8. - if( $] >= 5.008 ) { - open $fh, ">>", $file_or_fh - or $self->croak("Can't open scalar ref $file_or_fh: $!"); - } - # Emulate scalar ref filehandles with a tie. - else { - $fh = Test::Builder::IO::Scalar->new($file_or_fh) - or $self->croak("Can't tie scalar ref $file_or_fh"); - } - } - else { - open $fh, ">", $file_or_fh - or $self->croak("Can't open test output log $file_or_fh: $!"); - _autoflush($fh); - } - - return $fh; -} - -sub _autoflush ($fh) { - my $old_fh = select $fh; - $| = 1; - select $old_fh; - - return; -} - -my( $Testout, $Testerr ); - -sub _dup_stdhandles ($self) :method { - - $self->_open_testhandles; - - # Set everything to unbuffered else plain prints to STDOUT will - # come out in the wrong order from our own prints. - _autoflush($Testout); - _autoflush( \*STDOUT ); - _autoflush($Testerr); - _autoflush( \*STDERR ); - - $self->reset_outputs; - - return; -} - -sub _open_testhandles ($self) :method { - - return if $self->{Opened_Testhandles}; - - # We dup STDOUT and STDERR so people can change them in their - # test suites while still getting normal test output. - open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; - open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; - - $self->_copy_io_layers( \*STDOUT, $Testout ); - $self->_copy_io_layers( \*STDERR, $Testerr ); - - $self->{Opened_Testhandles} = 1; - - return; -} +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 _copy_io_layers ( $self, $src, $dst ) :method { +B is where normal "ok/not ok" test output goes. - $self->_try( - sub { - require PerlIO; - my @src_layers = PerlIO::get_layers($src); +Defaults to STDOUT. - _apply_layers($dst, @src_layers) if @src_layers; - } - ); +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. - return; -} +Defaults to STDERR. -sub _apply_layers ($fh, @layers) { - my %seen; - my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; - binmode($fh, join(":", "", "raw", @unique)); -} +C is used instead of C for the +diagnostics of a failing TODO test. These will not be seen by the +user. +Defaults to STDOUT. =item reset_outputs @@ -1906,17 +2229,6 @@ sub _apply_layers ($fh, @layers) { Resets all the output filehandles back to their defaults. -=cut - -sub reset_outputs ($self) :method { - - $self->output ($Testout); - $self->failure_output($Testerr); - $self->todo_output ($Testout); - - return; -} - =item carp $tb->carp(@message); @@ -1931,26 +2243,6 @@ point where the original test function was called (C<< $tb->caller >>). Dies with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). -=cut - -sub _message_at_caller { - my $self = shift; - - local $Level = $Level + 1; - my( $pack, $file, $line ) = $self->caller; - return join( "", @_ ) . " at $file line $line.\n"; -} - -sub carp { - my $self = shift; - return warn $self->_message_at_caller(@_); -} - -sub croak { - my $self = shift; - return die $self->_message_at_caller(@_); -} - =back @@ -1971,37 +2263,6 @@ If set forward, the details of the missing tests are filled in as 'unknown'. if set backward, the details of the intervening tests are deleted. You can erase history if you really want to. -=cut - -sub current_test ( $self, $num? ) :method { - - lock( $self->{Curr_Test} ); - if( defined $num ) { - $self->{Curr_Test} = $num; - - # If the test counter is being pushed forward fill in the details. - my $test_results = $self->{Test_Results}; - if( $num > @$test_results ) { - my $start = @$test_results ? @$test_results : 0; - for( $start .. $num - 1 ) { - $test_results->[$_] = &share( - { - 'ok' => 1, - actual_ok => undef, - reason => 'incrementing test number', - type => 'unknown', - name => undef - } - ); - } - } - # If backward, wipe history. Its their funeral. - elsif( $num < @$test_results ) { - $#{$test_results} = $num - 1; - } - } - return $self->{Curr_Test}; -} =item B @@ -2018,18 +2279,6 @@ test to it and start passing. Don't think about it too much. -=cut - -sub is_passing { - my $self = shift; - - if( @_ ) { - $self->{Is_Passing} = shift; - } - - return $self->{Is_Passing}; -} - =item B @@ -2040,13 +2289,6 @@ This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... -=cut - -sub summary { - my($self) = shift; - - return map { $_->{'ok'} } @{ $self->{Test_Results} }; -} =item B
@@ -2054,7 +2296,7 @@ sub summary { Like C, but with a lot more detail. - $tests[$test_num - 1] = + $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) @@ -2095,12 +2337,6 @@ result in this structure: reason => 'insufficient donuts' }; -=cut - -sub details { - my $self = shift; - return @{ $self->{Test_Results} }; -} =item B @@ -2124,20 +2360,6 @@ 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. -=cut - -sub todo { - my( $self, $pack ) = @_; - - return $self->{Todo} if defined $self->{Todo}; - - local $Level = $Level + 1; - my $todo = $self->find_TODO($pack); - return $todo if defined $todo; - - return ''; -} - =item B my $todo_reason = $Test->find_TODO(); @@ -2151,35 +2373,12 @@ old value: my $old_reason = $Test->find_TODO($pack, 1, $new_reason); -=cut - -sub find_TODO { - my( $self, $pack, $set, $new_value ) = @_; - - $pack = $pack || $self->caller(1) || $self->exported_to; - return unless $pack; - - no strict 'refs'; ## no critic - my $old_value = ${ $pack . '::TODO' }; - $set and ${ $pack . '::TODO' } = $new_value; - return $old_value; -} - =item B my $in_todo = $Test->in_todo; Returns true if the test is currently inside a TODO block. -=cut - -sub in_todo { - my $self = shift; - - local $Level = $Level + 1; - return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; -} - =item B $Test->todo_start(); @@ -2221,20 +2420,6 @@ guaranteed and its use is also discouraged: Pick one style or another of "TODO" to be on the safe side. -=cut - -sub todo_start { - my $self = shift; - my $message = @_ ? shift : ''; - - $self->{Start_Todo}++; - if( $self->in_todo ) { - push @{ $self->{Todo_Stack} } => $self->todo; - } - $self->{Todo} = $message; - - return; -} =item C @@ -2243,27 +2428,6 @@ sub todo_start { Stops running tests as "TODO" tests. This method is fatal if called without a preceding C method call. -=cut - -sub todo_end { - my $self = shift; - - if( !$self->{Start_Todo} ) { - $self->croak('todo_end() called without todo_start()'); - } - - $self->{Start_Todo}--; - - if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { - $self->{Todo} = pop @{ $self->{Todo_Stack} }; - } - else { - delete $self->{Todo}; - } - - return; -} - =item B my $package = $Test->caller; @@ -2276,233 +2440,8 @@ C<$height> will be added to the C. If C winds up off the top of the stack it report the highest context. -=cut - -sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my( $self, $height ) = @_; - $height ||= 0; - - my $level = $self->level + $height + 1; - my @caller; - do { - @caller = CORE::caller( $level ); - $level--; - } until @caller; - return wantarray ? @caller : $caller[0]; -} - -=back - -=cut - -=begin _private - -=over 4 - -=item B<_sanity_check> - - $self->_sanity_check(); - -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. - -=cut - -#'# -sub _sanity_check { - my $self = shift; - - $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); - $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, - 'Somehow you got a different number of results than tests ran!' ); - - return; -} - -=item B<_whoa> - - $self->_whoa($check, $description); - -A sanity check, similar to C. If the C<$check> is true, something -has gone horribly wrong. It will die with the given C<$description> and -a note to contact the author. - -=cut - -sub _whoa { - my( $self, $check, $desc ) = @_; - if($check) { - local $Level = $Level + 1; - $self->croak(<<"WHOA"); -WHOA! $desc -This should never happen! Please contact the author immediately! -WHOA - } - - return; -} - -=item B<_my_exit> - - _my_exit($exit_num); - -Perl seems to have some trouble with exiting inside an C 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. - -=cut - -sub _my_exit { - $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) - - return 1; -} - =back -=end _private - -=cut - -sub _ending { - my $self = shift; - return if $self->no_ending; - return if $self->{Ending}++; - - my $real_exit_code = $?; - - # Don't bother with an ending if this is a forked copy. Only the parent - # should do the ending. - if( $self->{Original_Pid} != $$ ) { - return; - } - - # Ran tests but never declared a plan or hit done_testing - if( !$self->{Have_Plan} and $self->{Curr_Test} ) { - $self->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; - } - - # 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) { - - my $exit_code = $num_failed <= 254 ? $num_failed : 254; - _my_exit($exit_code) && return; - } - } - _my_exit(254) && return; - } - - # Exit if plan() was never called. This is so "require Test::Simple" - # doesn't puke. - if( !$self->{Have_Plan} ) { - return; - } - - # Don't do an ending if we bailed out. - if( $self->{Bailed_Out} ) { - $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}; - } - - # Auto-extended arrays and elements which aren't explicitly - # filled in with a shared reference will puke under 5.8.0 - # ithreads. So we have to fill them in by hand. :( - my $empty_result = &share( {} ); - for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { - $test_results->[$idx] = $empty_result - unless defined $test_results->[$idx]; - } - - my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; - - my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - - if( $num_extra != 0 ) { - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. -FAIL - $self->is_passing(0); - } - - if($num_failed) { - my $num_tests = $self->{Curr_Test}; - my $s = $num_failed == 1 ? '' : 's'; - - my $qualifier = $num_extra == 0 ? '' : ' run'; - - $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $num_tests$qualifier. -FAIL - $self->is_passing(0); - } - - 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; - } - - _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()" ); -} - -END { - $Test->_ending if defined $Test; -} - =head1 EXIT CODES If all your tests passed, Test::Builder will exit with zero (which is @@ -2523,9 +2462,9 @@ If you fail more than 254 tests, it will be reported as 254. =head1 THREADS -In perl 5.8.1 and later, Test::Builder is thread-safe. The test -number is shared amongst all threads. This means if one thread sets -the test number using C they will all be effected. +In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is +shared by all threads. This means if one thread sets the test number using +C they will all be effected. While versions earlier than 5.8.1 had threads they contain too many bugs to support. @@ -2579,8 +2518,3 @@ 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/dist/Test-Simple/lib/Test/Builder/Formatter.pm b/dist/Test-Simple/lib/Test/Builder/Formatter.pm new file mode 100644 index 00000000000..ac569460eaa --- /dev/null +++ b/dist/Test-Simple/lib/Test/Builder/Formatter.pm @@ -0,0 +1,122 @@ +package Test::Builder::Formatter; +use strict; +use warnings; + +our $VERSION = '1.302075'; + +BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } + +use Test2::Util::HashBase qw/no_header no_diag/; + +BEGIN { + *OUT_STD = Test2::Formatter::TAP->can('OUT_STD'); + *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR'); + + my $todo = OUT_ERR() + 1; + *OUT_TODO = sub() { $todo }; +} + +__PACKAGE__->register_event('Test::Builder::TodoDiag', 'event_todo_diag'); + +sub init { + my $self = shift; + $self->SUPER::init(@_); + $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; +} + +sub event_todo_diag { + my $self = shift; + my @out = $self->event_diag(@_); + $out[0]->[0] = OUT_TODO(); + return @out; +} + +sub event_diag { + my $self = shift; + return if $self->{+NO_DIAG}; + return $self->SUPER::event_diag(@_); +} + +sub event_plan { + my $self = shift; + return if $self->{+NO_HEADER}; + return $self->SUPER::event_plan(@_); +} + +sub event_ok_multiline { + my $self = shift; + my ($out, $space, @extra) = @_; + + return( + [OUT_STD, "$out\n"], + map {[OUT_STD, "# $_\n"]} @extra, + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP + +=head1 DESCRIPTION + +This is what takes events and turns them into TAP. + +=head1 SYNOPSIS + + use Test::Builder; # Loads Test::Builder::Formatter for you + +=head1 METHODS + +=over 4 + +=item $f->event_todo_diag + +Additional method used to process L events. + +=item $f->event_diag + +=item $f->event_plan + +These override the parent class methods to do nothing if C is set. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test/Builder/Module.pm b/dist/Test-Simple/lib/Test/Builder/Module.pm index 4f0918d73ee..012759b50fb 100644 --- a/dist/Test-Simple/lib/Test/Builder/Module.pm +++ b/dist/Test-Simple/lib/Test/Builder/Module.pm @@ -2,13 +2,13 @@ package Test::Builder::Module; use strict; -use Test::Builder 1.00; +use Test::Builder; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.401015c'; -$VERSION =~ s/c$//; +our $VERSION = '1.302075'; + =head1 NAME @@ -21,7 +21,7 @@ Test::Builder::Module - Base class for test modules my $CLASS = __PACKAGE__; - use base 'Test::Builder::Module'; + use parent 'Test::Builder::Module'; @EXPORT = qw(ok); sub ok ($;$) { @@ -72,10 +72,9 @@ C. =cut -#sub import ($class, @args) { sub import { - my $class = shift; - my @args = @_; + my($class) = shift; + # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; @@ -85,20 +84,18 @@ sub import { $test->exported_to($caller); - # if called with arrayref - #if (@args and scalar(@args) == 1 and ref($args[0]) eq 'ARRAY') { - # @args = ($args[0]); - # warn @args; - #} - $class->import_extra( \@args ); - my(@imports) = $class->_strip_imports( \@args ); + $class->import_extra( \@_ ); + my(@imports) = $class->_strip_imports( \@_ ); - $test->plan(@args); + $test->plan(@_); - $class->export_to_level( 1, $class, @imports ); + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + $class->Exporter::import(@imports); } -sub _strip_imports ($class, $list) { +sub _strip_imports { + my $class = shift; + my $list = shift; my @imports = (); my @other = (); @@ -169,7 +166,7 @@ call C inside each function rather than store it in a global. =cut -sub builder () { +sub builder { return Test::Builder->new; } diff --git a/dist/Test-Simple/lib/Test/Builder/Tester.pm b/dist/Test-Simple/lib/Test/Builder/Tester.pm index ef04debe706..c30ff1d0710 100644 --- a/dist/Test-Simple/lib/Test/Builder/Tester.pm +++ b/dist/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,9 +1,9 @@ package Test::Builder::Tester; use strict; -our $VERSION = "1.29c"; +our $VERSION = '1.302075'; -use Test::Builder 0.99; +use Test::Builder; use Symbol; use Carp; @@ -104,16 +104,26 @@ my $original_is_passing; my $original_output_handle; my $original_failure_handle; my $original_todo_handle; +my $original_formatter; my $original_harness_env; # function that starts testing and redirects the filehandles for now sub _start_testing { + # Hack for things that conditioned on Test-Stream being loaded + $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'}; # even if we're running under Test::Harness pretend we're not # for now. This needed so Test::Builder doesn't add extra spaces $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; + my $hub = $t->{Hub} || Test2::API::test2_stack->top; + $original_formatter = $hub->format; + unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) { + my $fmt = Test::Builder::Formatter->new; + $hub->format($fmt); + } + # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); @@ -304,6 +314,8 @@ will function normally and cause success/errors for L. =cut sub test_test { + # END the hack + delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake'; # decode the arguments as described in the pod my $mess; my %args; @@ -321,6 +333,10 @@ sub test_test { croak "Not testing. You must declare output with a test function first." unless $testing; + + my $hub = $t->{Hub} || Test2::API::test2_stack->top; + $hub->format($original_formatter); + # okay, reconnect the test suite back to the saved handles $t->output($original_output_handle); $t->failure_output($original_failure_handle); @@ -420,17 +436,26 @@ sub color { =head1 BUGS +Test::Builder::Tester does not handle plans well. It has never done anything +special with plans. This means that plans from outside Test::Builder::Tester +will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester +will effect overall testing. At this point there are no plans to fix this bug +as people have come to depend on it, and Test::Builder::Tester is now +discouraged in favor of C. See +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. The color function doesn't work unless L is -compatible with your terminal. +compatible with your terminal. Additionally, L +must be installed on windows platforms for color output. Bugs (and requests for new features) can be reported to the author -though the CPAN RT system: -L +though GitHub: +L =head1 AUTHOR @@ -484,13 +509,16 @@ sub expect { } } -sub _account_for_subtest ( $self, $check ) :method { +sub _account_for_subtest { + my( $self, $check ) = @_; - # Since we ship with Test::Builder, calling a private method is safe...ish. - return ref($check) ? $check : $t->_indent . $check; + my $hub = $t->{Stack}->top; + my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0; + return ref($check) ? $check : (' ' x $nesting) . $check; } -sub _translate_Failed_check ( $self, $check ) :method { +sub _translate_Failed_check { + my( $self, $check ) = @_; if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; @@ -502,7 +530,8 @@ sub _translate_Failed_check ( $self, $check ) :method { ## # return true iff the expected data matches the got data -sub check ($self) :method { +sub check { + my $self = shift; # turn off warnings as these might be undef local $^W = 0; @@ -521,7 +550,8 @@ sub check ($self) :method { # a complaint message about the inputs not matching (to be # used for debugging messages) -sub complaint ($self) :method { +sub complaint { + my $self = shift; my $type = $self->type; my $got = $self->got; my $wanted = join '', @{ $self->wanted }; @@ -531,6 +561,8 @@ sub complaint ($self) :method { # get color eval { require Term::ANSIColor }; unless($@) { + eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms + # colours my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); @@ -559,13 +591,41 @@ sub complaint ($self) :method { } } + my @got = split "\n", $got; + my @wanted = split "\n", $wanted; + + $got = ""; + $wanted = ""; + + while (@got || @wanted) { + my $g = shift @got || ""; + my $w = shift @wanted || ""; + if ($g ne $w) { + if($g =~ s/(\s+)$/ |> /g) { + $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1; + } + if($w =~ s/(\s+)$/ |> /g) { + $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1; + } + $g = "> $g"; + $w = "> $w"; + } + else { + $g = " $g"; + $w = " $w"; + } + $got = $got ? "$got\n$g" : $g; + $wanted = $wanted ? "$wanted\n$w" : $w; + } + return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; } ## # forget all expected and got data -sub reset ($self) :method { +sub reset { + my $self = shift; %$self = ( type => $self->{type}, got => '', @@ -573,15 +633,18 @@ sub reset ($self) :method { ); } -sub got ($self) :method { +sub got { + my $self = shift; return $self->{got}; } -sub wanted ($self) :method { +sub wanted { + my $self = shift; return $self->{wanted}; } -sub type ($self) :method { +sub type { + my $self = shift; return $self->{type}; } @@ -589,15 +652,18 @@ sub type ($self) :method { # tie interface ### -sub PRINT :method { +sub PRINT { my $self = shift; $self->{got} .= join '', @_; } -sub TIEHANDLE ( $class, $type ) :method { +sub TIEHANDLE { + my( $class, $type ) = @_; my $self = bless { type => $type }, $class; + $self->reset; + return $self; } diff --git a/dist/Test-Simple/lib/Test/Builder/Tester/Color.pm b/dist/Test-Simple/lib/Test/Builder/Tester/Color.pm index 9a89310f1f3..107013384a2 100644 --- a/dist/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/dist/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = "1.290001"; +our $VERSION = '1.302075'; require Test::Builder::Tester; diff --git a/dist/Test-Simple/lib/Test/Builder/TodoDiag.pm b/dist/Test-Simple/lib/Test/Builder/TodoDiag.pm new file mode 100644 index 00000000000..db96d6d9aef --- /dev/null +++ b/dist/Test-Simple/lib/Test/Builder/TodoDiag.pm @@ -0,0 +1,61 @@ +package Test::Builder::TodoDiag; +use strict; +use warnings; + +our $VERSION = '1.302075'; + +BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } + +sub diagnostics { 0 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag + +=head1 DESCRIPTION + +This is used to encapsulate diag messages created inside TODO. + +=head1 SYNOPSIS + +You do not need to use this directly. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test/More.pm b/dist/Test-Simple/lib/Test/More.pm index 94f6fbec1f5..0bfc06f6ab0 100644 --- a/dist/Test-Simple/lib/Test/More.pm +++ b/dist/Test-Simple/lib/Test/More.pm @@ -17,10 +17,9 @@ sub _carp { return warn @_, " at $file line $line\n"; } -our $VERSION = '1.401015c'; -$VERSION =~ s/c$//; +our $VERSION = '1.302075'; -use Test::Builder::Module 0.99; +use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply @@ -126,6 +125,8 @@ the end. done_testing( $number_of_tests_run ); +B C should never be called in an C block. + Sometimes you really don't know how many tests were run, or it's too difficult to calculate. In which case you can leave off $number_of_tests_run. @@ -162,22 +163,36 @@ or for deciding between running the tests at all: =cut -# TODO (...) -sub plan (@args) { - Test::More->builder->plan(@args); +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 ($class, $list) { +sub import_extra { + my $class = shift; + my $list = shift; + my @other = (); my $idx = 0; + my $import; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } + elsif( defined $item and $item eq 'import' ) { + if ($import) { + push @$import, @{$list->[ ++$idx ]}; + } + else { + $import = $list->[ ++$idx ]; + push @other, $item, $import; + } + } else { push @other, $item; } @@ -187,6 +202,18 @@ sub import_extra ($class, $list) { @$list = @other; + if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { + my $to = $class->builder->exported_to; + no strict 'refs'; + *{"$to\::TODO"} = \our $TODO; + if ($import) { + @$import = grep $_ ne '$TODO', @$import; + } + else { + push @$list, import => [grep $_ ne '$TODO', @EXPORT]; + } + } + return; } @@ -207,12 +234,17 @@ conclusion. This is safer than and replaces the "no_plan" plan. +B You must never put C inside an C block. +The plan is there to ensure your test does not exit before testing has +completed. If you use an END block you completely bypass this protection. + =back =cut sub done_testing { - Test::More->builder->done_testing(@_); + my $tb = Test::More->builder; + $tb->done_testing(@_); } =head2 Test names @@ -282,8 +314,11 @@ This is the same as L's C routine. =cut -sub ok ($test, $name?) { - Test::More->builder->ok( $test, $name ); +sub ok ($;$) { + my( $test, $name ) = @_; + my $tb = Test::More->builder; + + return $tb->ok( $test, $name ); } =item B @@ -363,14 +398,18 @@ function which is an alias of C. =cut sub is ($$;$) { - Test::More->builder->is_eq(@_); + my $tb = Test::More->builder; + + return $tb->is_eq(@_); } sub isnt ($$;$) { - Test::More->builder->isnt_eq(@_); + my $tb = Test::More->builder; + + return $tb->isnt_eq(@_); } -# *isn't = \&isnt; +*isn't = \&isnt; # ' to unconfuse syntax higlighters =item B @@ -404,7 +443,9 @@ diagnostics on failure. =cut sub like ($$;$) { - Test::More->builder->like(@_); + my $tb = Test::More->builder; + + return $tb->like(@_); } =item B @@ -417,7 +458,9 @@ given pattern. =cut sub unlike ($$;$) { - Test::More->builder->unlike(@_); + my $tb = Test::More->builder; + + return $tb->unlike(@_); } =item B @@ -461,7 +504,9 @@ relation between values: =cut sub cmp_ok($$$;$) { - Test::More->builder->cmp_ok(@_); + my $tb = Test::More->builder; + + return $tb->cmp_ok(@_); } =item B @@ -493,7 +538,8 @@ as one test. If you desire otherwise, use: =cut -sub can_ok ($proto, @methods) { +sub can_ok ($@) { + my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; @@ -558,7 +604,8 @@ you'd like them to be more specific, you can supply an $object_name =cut -sub isa_ok ($thing, $class, $thing_name?) { +sub isa_ok ($$;$) { + my( $thing, $class, $thing_name ) = @_; my $tb = Test::More->builder; my $whatami; @@ -658,20 +705,22 @@ just a single object which isa C<$class>. =cut -sub new_ok ($class, $args?, $object_name?) { +sub new_ok { my $tb = Test::More->builder; - # $tb->croak("new_ok() must be given at least a class") unless defined $class; + $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) { + 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); + isa_ok $obj, $class, $object_name; } else { - $class = 'undef' if !length $class; + $class = 'undef' if !defined $class; $tb->ok( 0, "$class->new() died" ); $tb->diag(" Error was: $error"); } @@ -740,10 +789,22 @@ subtests are equivalent: done_testing(); }; +Extra arguments given to C are passed to the callback. For example: + + sub my_subtest { + my $range = shift; + ... + } + + for my $range (1, 10, 100, 1000) { + subtest "testing range $range", \&my_subtest, $range; + } + =cut -sub subtest ($name, $subtests, @args) { - Test::More->builder->subtest($name, $subtests, @args); +sub subtest { + my $tb = Test::More->builder; + return $tb->subtest(@_); } =item B @@ -764,11 +825,15 @@ Use these very, very, very sparingly. =cut sub pass (;$) { - Test::More->builder->ok( 1, @_ ); + my $tb = Test::More->builder; + + return $tb->ok( 1, @_ ); } sub fail (;$) { - Test::More->builder->ok( 0, @_ ); + my $tb = Test::More->builder; + + return $tb->ok( 0, @_ ); } =back @@ -812,7 +877,8 @@ No exception will be thrown if the load fails. =cut -sub require_ok ($module) { +sub require_ok ($) { + my($module) = shift; my $tb = Test::More->builder; my $pack = caller; @@ -842,7 +908,8 @@ DIAGNOSTIC return $ok; } -sub _is_module_name (str $module) { +sub _is_module_name { + my $module = shift; # Module names start with a letter. # End with an alphanumeric. @@ -904,11 +971,15 @@ import anything, use C. =cut -sub use_ok { #($module, @imports) { # XXX segv! - my ($module, @imports) = @_; +sub use_ok ($;@) { + my( $module, @imports ) = @_; + @imports = () unless @imports; my $tb = Test::More->builder; - my( $pack, $filename, $line ) = caller; + my %caller; + @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); + + my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line my $code; @@ -917,7 +988,7 @@ sub use_ok { #($module, @imports) { # XXX segv! # for it to work with non-Exporter based modules. $code = <ok( $eval_result, "use $module;" ); unless($ok) { @@ -950,7 +1021,8 @@ DIAGNOSTIC return $ok; } -sub _eval ( $code, @args ) { +sub _eval { + my( $code, @args ) = @_; # Work around oddities surrounding resetting of $@ by immediately # storing it. @@ -1001,13 +1073,27 @@ improve in the future. L and L provide more in-depth functionality along these lines. +B is_deeply() has limitations when it comes to comparing strings and +refs: + + my $path = path('.'); + my $hash = {}; + is_deeply( $path, "$path" ); # ok + is_deeply( $hash, "$hash" ); # fail + +This happens because is_deeply will unoverload all arguments unconditionally. +It is probably best not to use is_deeply with overloading. For legacy reasons +this is not likely to ever be fixed. If you would like a much better tool for +this you should see L Specifically L has +an C function that works like C with many improvements. + =cut our( @Data_Stack, %Refs_Seen ); my $DNE = bless [], 'Does::Not::Exist'; -sub _dne ($obj) { - return ref $obj eq ref $DNE; +sub _dne { + return ref $_[0] eq ref $DNE; } ## no critic (Subroutines::RequireArgUnpacking) @@ -1017,7 +1103,7 @@ sub is_deeply { 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 +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 @@ -1053,7 +1139,9 @@ WARNING return $ok; } -sub _format_stack (@Stack) { +sub _format_stack { + my(@Stack) = @_; + my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { @@ -1094,11 +1182,12 @@ sub _format_stack (@Stack) { return $out; } -sub _type ($thing) { +sub _type { + my $thing = shift; return '' if !ref $thing; - for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) { + for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { return $type if UNIVERSAL::isa( $thing, $type ); } @@ -1161,11 +1250,11 @@ don't indicate a problem. =cut sub diag { - Test::More->builder->diag(@_); + return Test::More->builder->diag(@_); } sub note { - Test::More->builder->note(@_); + return Test::More->builder->note(@_); } =item B @@ -1187,7 +1276,7 @@ or =cut sub explain { - Test::More->builder->explain(@_); + return Test::More->builder->explain(@_); } =back @@ -1253,21 +1342,25 @@ use TODO. Read on. =cut ## no critic (Subroutines::RequireFinalReturn) -sub skip ( str $why = "", Numeric $how_many = 0) { +sub skip { + my( $why, $how_many ) = @_; my $tb = Test::More->builder; - unless ($how_many) { - # $how_many can only be avoided when no_plan is in use. + # If the plan is set, and is static, then skip needs a count. If the plan + # is 'no_plan' we are fine. As well if plan is undefined then we are + # waiting for done_testing. + unless (defined $how_many) { + my $plan = $tb->has_plan; _carp "skip() needs to know \$how_many tests are in the block" - if !defined($tb->has_plan) or $tb->has_plan ne 'no_plan'; + if $plan && $plan =~ m/^\d+$/; $how_many = 1; } - #if ($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; - #} + 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); @@ -1335,13 +1428,14 @@ interpret them as passing. =cut -sub todo_skip ( str $why = "", Numeric $how_many = 0) { +sub todo_skip { + my( $why, $how_many ) = @_; my $tb = Test::More->builder; - unless ($how_many) { + 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" - if !defined($tb->has_plan) or $tb->has_plan ne 'no_plan'; + unless $tb->has_plan eq 'no_plan'; $how_many = 1; } @@ -1374,7 +1468,7 @@ but want to put tests in your testing script (always a good idea). =item B - BAIL_OUT($reason?); + BAIL_OUT($reason); Indicates to the harness that things are going so badly all testing should terminate. This includes the running of any additional test scripts. @@ -1389,8 +1483,11 @@ For even better control look at L. =cut -sub BAIL_OUT (str $reason="") { - Test::More->builder->BAIL_OUT($reason); +sub BAIL_OUT { + my $reason = shift; + my $tb = Test::More->builder; + + $tb->BAIL_OUT($reason); } =back @@ -1431,8 +1528,8 @@ sub eq_array { _deep_check(@_); } -#sub _eq_array ( \@a1, \@a2 ) { -sub _eq_array ( $a1, $a2 ) { +sub _eq_array { + my( $a1, $a2 ) = @_; if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; @@ -1459,7 +1556,8 @@ sub _eq_array ( $a1, $a2 ) { return $ok; } -sub _equal_nonrefs ( $e1?, $e2? ) { +sub _equal_nonrefs { + my( $e1, $e2 ) = @_; return if ref $e1 or ref $e2; @@ -1473,8 +1571,10 @@ sub _equal_nonrefs ( $e1?, $e2? ) { return; } -sub _deep_check ( $e1?, $e2? ) { +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 @@ -1550,8 +1650,9 @@ sub _deep_check ( $e1?, $e2? ) { return $ok; } -sub _whoa ( int $check, str $desc ) { - if ($check) { +sub _whoa { + my( $check, $desc ) = @_; + if($check) { die <<"WHOA"; WHOA! $desc This should never happen! Please contact the author immediately! @@ -1566,17 +1667,15 @@ WHOA Determines if the two hashes contain the same keys and values. This is a deep check. -A third argument is currently ignored. - =cut -sub eq_hash ($h1?, $h2?, $?) { +sub eq_hash { local @Data_Stack = (); - return _deep_check($h1, $h2); + return _deep_check(@_); } -#sub _eq_hash (\%a1, \%a2) { -sub _eq_hash ($a1, $a2) { +sub _eq_hash { + my( $a1, $a2 ) = @_; if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; @@ -1605,7 +1704,7 @@ sub _eq_hash ($a1, $a2) { =item B - my $is_eq = eq_set(\@got, \@expected, [$desc]); + my $is_eq = eq_set(\@got, \@expected); Similar to C, except the order of the elements is B important. This is a deep check, but the irrelevancy of order only @@ -1627,12 +1726,10 @@ level. The following is an example of a comparison which might not work: L contains much better set comparison functions. -The third argument is currently ignored. - =cut -#sub eq_set ( \@a1, \@a2 ) { -sub eq_set ( $a1, $a2, $desc? ) { +sub eq_set { + my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; no warnings 'uninitialized'; @@ -1649,8 +1746,8 @@ sub eq_set ( $a1, $a2, $desc? ) { # 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 ) ) ], + [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], + [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } @@ -1862,8 +1959,6 @@ comes from. =head2 BUNDLES -L installs a whole bunch of useful test modules. - L Most commonly needed test functions and features. =head1 AUTHORS @@ -1884,7 +1979,7 @@ the perl-qa gang. =head1 BUGS -See F to report and view bugs. +See F to report and view bugs. =head1 SOURCE @@ -1896,7 +1991,6 @@ F. =head1 COPYRIGHT Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. -Copyright 2015 cPanel Inc This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/dist/Test-Simple/lib/Test/Simple.pm b/dist/Test-Simple/lib/Test/Simple.pm index 86bb2aa638e..187a3d25b08 100644 --- a/dist/Test-Simple/lib/Test/Simple.pm +++ b/dist/Test-Simple/lib/Test/Simple.pm @@ -4,10 +4,9 @@ use 5.006; use strict; -our $VERSION = '1.401015'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +our $VERSION = '1.302075'; -use Test::Builder::Module 0.99; +use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok); diff --git a/dist/Test-Simple/lib/Test/Tester.pm b/dist/Test-Simple/lib/Test/Tester.pm index a5f1ccfdbb8..f0d14207fcf 100644 --- a/dist/Test-Simple/lib/Test/Tester.pm +++ b/dist/Test-Simple/lib/Test/Tester.pm @@ -16,9 +16,10 @@ use Test::Tester::Delegate; require Exporter; -use vars qw( @ISA @EXPORT $VERSION ); +use vars qw( @ISA @EXPORT ); + +our $VERSION = '1.302075'; -$VERSION = "0.114"; @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @ISA = qw( Exporter ); @@ -39,10 +40,11 @@ sub show_space my $colour = ''; my $reset = ''; -if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR}) +if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR}) { - if (eval "require Term::ANSIColor") + if (eval { require Term::ANSIColor; 1 }) { + eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms my ($f, $b) = split(",", $want_colour); $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); $reset = Term::ANSIColor::color("reset"); @@ -446,7 +448,7 @@ diagnostics output B the test result is declared. Note that Test::Builder ensures that any diagnostics end in a \n and it in earlier versions of Test::Tester it was essential that you have -the final \n in your expected diagnostics. From version 0.10 onwards, +the final \n in your expected diagnostics. From version 0.10 onward, Test::Tester will add the \n if you forgot it. It will not add a \n if you are expecting no diagnostics. See below for help tracking down hard to find space and tab related problems. @@ -495,7 +497,7 @@ are scratching your head trying to work out why Test::Tester is saying that your diagnostics are wrong when they look perfectly right then the answer is probably whitespace. From version 0.10 on, Test::Tester surrounds the expected and got diag values with single quotes to make it easier to spot -trailing whitesapce. So in this example +trailing whitespace. So in this example # Got diag (5 bytes): # 'abcd ' @@ -513,7 +515,7 @@ switch Test::Tester into a mode whereby all "tricky" characters are shown as \{xx}. Tricky characters are those with ASCII code less than 33 or higher than 126. This makes the output more difficult to read but much easier to find subtle differences between strings. To turn on this mode either call -show_space() in your test script or set the TESTTESTERSPACE environment +C in your test script or set the C environment variable to be a true value. The example above would then look like # Got diag (5 bytes): @@ -524,13 +526,13 @@ variable to be a true value. The example above would then look like =head1 COLOUR If you prefer to use colour as a means of finding tricky whitespace -characters then you can set the TESTTESTCOLOUR environment variable to a +characters then you can set the C environment variable to a comma separated pair of colours, the first for the foreground, the second for the background. For example "white,red" will print white text on a red background. This requires the Term::ANSIColor module. You can specify any colour that would be acceptable to the Term::ANSIColor::color function. -If you spell colour differently, that's no problem. The TESTTESTERCOLOR +If you spell colour differently, that's no problem. The C variable also works (if both are set then the British spelling wins out). =head1 EXPORTED FUNCTIONS diff --git a/dist/Test-Simple/lib/Test/Tester/Capture.pm b/dist/Test-Simple/lib/Test/Tester/Capture.pm index 00e12e6458e..46470c1bf65 100644 --- a/dist/Test-Simple/lib/Test/Tester/Capture.pm +++ b/dist/Test-Simple/lib/Test/Tester/Capture.pm @@ -2,6 +2,9 @@ use strict; package Test::Tester::Capture; +our $VERSION = '1.302075'; + + use Test::Builder; use vars qw( @ISA ); @@ -42,6 +45,8 @@ sub new sub ok { my($self, $test, $name) = @_; + my $ctx = $self->ctx; + # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; @@ -51,7 +56,7 @@ sub ok { my($pack, $file, $line) = $self->caller; - my $todo = $self->todo($pack); + my $todo = $self->todo(); my $result = {}; share($result); @@ -92,6 +97,8 @@ sub ok { $result->{_level} = $Test::Builder::Level; $result->{_depth} = Test::Tester::find_run_tests(); + $ctx->release; + return $test ? 1 : 0; } @@ -99,6 +106,8 @@ sub skip { my($self, $why) = @_; $why ||= ''; + my $ctx = $self->ctx; + lock($Curr_Test); $Curr_Test++; @@ -116,6 +125,7 @@ sub skip { ); $Test_Results[$Curr_Test-1] = \%result; + $ctx->release; return 1; } @@ -123,6 +133,8 @@ sub todo_skip { my($self, $why) = @_; $why ||= ''; + my $ctx = $self->ctx; + lock($Curr_Test); $Curr_Test++; @@ -141,6 +153,7 @@ sub todo_skip { $Test_Results[$Curr_Test-1] = \%result; + $ctx->release; return 1; } @@ -151,6 +164,8 @@ sub diag { # Prevent printing headers when compiling (i.e. -c) return if $^C; + my $ctx = $self->ctx; + # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; @@ -162,6 +177,7 @@ sub diag { $result->{diag} .= join("", @msgs); + $ctx->release; return 0; } diff --git a/dist/Test-Simple/lib/Test/Tester/CaptureRunner.pm b/dist/Test-Simple/lib/Test/Tester/CaptureRunner.pm index f14a4c145aa..a8258484326 100644 --- a/dist/Test-Simple/lib/Test/Tester/CaptureRunner.pm +++ b/dist/Test-Simple/lib/Test/Tester/CaptureRunner.pm @@ -3,6 +3,9 @@ use strict; package Test::Tester::CaptureRunner; +our $VERSION = '1.302075'; + + use Test::Tester::Capture; require Exporter; diff --git a/dist/Test-Simple/lib/Test/Tester/Delegate.pm b/dist/Test-Simple/lib/Test/Tester/Delegate.pm index 7ddb921cdfc..c72d82a43aa 100644 --- a/dist/Test-Simple/lib/Test/Tester/Delegate.pm +++ b/dist/Test-Simple/lib/Test/Tester/Delegate.pm @@ -3,6 +3,10 @@ use warnings; package Test::Tester::Delegate; +our $VERSION = '1.302075'; + +use Scalar::Util(); + use vars '$AUTOLOAD'; sub new @@ -29,4 +33,13 @@ sub AUTOLOAD goto &$ref; } +sub can { + my $this = shift; + my ($sub) = @_; + + return $this->{Object}->can($sub) if Scalar::Util::blessed($this); + + return $this->SUPER::can(@_); +} + 1; diff --git a/dist/Test-Simple/lib/Test/use/ok.pm b/dist/Test-Simple/lib/Test/use/ok.pm index 87d7cc52a55..729fe728271 100644 --- a/dist/Test-Simple/lib/Test/use/ok.pm +++ b/dist/Test-Simple/lib/Test/use/ok.pm @@ -1,6 +1,8 @@ package Test::use::ok; use 5.005; -$Test::use::ok::VERSION = '0.16'; + +our $VERSION = '1.302075'; + __END__ diff --git a/dist/Test-Simple/lib/Test2.pm b/dist/Test-Simple/lib/Test2.pm new file mode 100644 index 00000000000..854f37c930f --- /dev/null +++ b/dist/Test-Simple/lib/Test2.pm @@ -0,0 +1,213 @@ +package Test2; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2 - Framework for writing test tools that all work together. + +=head1 DESCRIPTION + +Test2 is a new testing framework produced by forking L, +completely refactoring it, adding many new features and capabilities. + +=head2 WHAT IS NEW? + +=over 4 + +=item Easier to test new testing tools. + +From the beginning Test2 was built with introspection capabilities. With +Test::Builder it was difficult at best to capture test tool output for +verification. Test2 Makes it easy with C. + +=item Better diagnostics capabilities. + +Test2 uses an L object to track filename, line number, and +tool details. This object greatly simplifies tracking for where errors should +be reported. + +=item Event driven. + +Test2 based tools produce events which get passed through a processing system +before being output by a formatter. This event system allows for rich plugin +and extension support. + +=item More complete API. + +Test::Builder only provided a handful of methods for generating lines of TAP. +Test2 took inventory of everything people were doing with Test::Builder that +required hacking it up. Test2 made public API functions for nearly all the +desired functionality people didn't previously have. + +=item Support for output other than TAP. + +Test::Builder assumed everything would end up as TAP. Test2 makes no such +assumption. Test2 provides ways for you to specify alternative and custom +formatters. + +=item Subtest implementation is more sane. + +The Test::Builder implementation of subtests was certifiably insane. Test2 uses +a stacked event hub system that greatly improves how subtests are implemented. + +=item Support for threading/forking. + +Test2 support for forking and threading can be turned on using L. +Once turned on threading and forking operate sanely and work as one would +expect. + +=back + +=head1 GETTING STARTED + +If you are interested in writing tests using new tools then you should look at +L. L is a separate cpan distribution that contains +many tools implemented on Test2. + +If you are interested in writing new tools you should take a look at +L first. + +=head1 NAMESPACE LAYOUT + +This describes the namespace layout for the Test2 ecosystem. Not all the +namespaces listed here are part of the Test2 distribution, some are implemented +in L. + +=head2 Test2::Tools:: + +This namespace is for sets of tools. Modules in this namespace should export +tools like C and C. Most things written for Test2 should go here. +Modules in this namespace B export subs from other tools. See the +L namespace if you want to do that. + +=head2 Test2::Plugin:: + +This namespace is for plugins. Plugins are modules that change or enhance the +behavior of Test2. An example of a plugin is a module that sets the encoding to +utf8 globally. Another example is a module that causes a bail-out event after +the first test failure. + +=head2 Test2::Bundle:: + +This namespace is for bundles of tools and plugins. Loading one of these may +load multiple tools and plugins. Modules in this namespace should not implement +tools directly. In general modules in this namespace should load tools and +plugins, then re-export things into the consumers namespace. + +=head2 Test2::Require:: + +This namespace is for modules that cause a test to be skipped when conditions +do not allow it to run. Examples would be modules that skip the test on older +perls, or when non-essential modules have not been installed. + +=head2 Test2::Formatter:: + +Formatters live under this namespace. L is the only +formatter currently. It is acceptable for third party distributions to create +new formatters under this namespace. + +=head2 Test2::Event:: + +Events live under this namespace. It is considered acceptable for third party +distributions to add new event types in this namespace. + +=head2 Test2::Hub:: + +Hub subclasses (and some hub utility objects) live under this namespace. It is +perfectly reasonable for third party distributions to add new hub subclasses in +this namespace. + +=head2 Test2::IPC:: + +The IPC subsystem lives in this namespace. There are not many good reasons to +add anything to this namespace, with exception of IPC drivers. + +=head3 Test2::IPC::Driver:: + +IPC drivers live in this namespace. It is fine to create new IPC drivers and to +put them in this namespace. + +=head2 Test2::Util:: + +This namespace is for general utilities used by testing tools. Please be +considerate when adding new modules to this namespace. + +=head2 Test2::API:: + +This is for Test2 API and related packages. + +=head2 Test2:: + +The Test2:: namespace is intended for extensions and frameworks. Tools, +Plugins, etc should not go directly into this namespace. However extensions +that are used to build tools and plugins may go here. + +In short: If the module exports anything that should be run directly by a test +script it should probably NOT go directly into C. + +=head1 SEE ALSO + +L - Primary API functions. + +L - Detailed documentation of the context object. + +L - The IPC system used for threading/fork support. + +L - Formatters such as TAP live here. + +L - Events live in this namespace. + +L - All events eventually funnel through a hub. Custom hubs are how +C and C are implemented. + +=head1 CONTACTING US + +Many Test2 developers and users lurk on L and +L. We also have a slack team that can be joined +by anyone with an C<@cpan.org> email address L +If you do not have an C<@cpan.org> email you can ask for a slack invite by +emailing Chad Granum Eexodist@cpan.orgE. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/API.pm b/dist/Test-Simple/lib/Test2/API.pm new file mode 100644 index 00000000000..eeb9a7bd7d4 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/API.pm @@ -0,0 +1,1335 @@ +package Test2::API; +use strict; +use warnings; + +BEGIN { + $ENV{TEST_ACTIVE} ||= 1; + $ENV{TEST2_ACTIVE} = 1; +} + +our $VERSION = '1.302075'; + + +my $INST; +my $ENDING = 0; +sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) } +sub test2_get_is_end { $ENDING } + +use Test2::API::Instance(\$INST); +# Set the exit status +END { + test2_set_is_end(); # See gh #16 + $INST->set_exit(); +} + +# See gh #16 +{ + no warnings; + INIT { eval 'END { test2_set_is_end() }; 1' or die $@ } +} + +BEGIN { + no warnings 'once'; + if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) { + *DO_DEPTH_CHECK = sub() { 1 }; + } + else { + *DO_DEPTH_CHECK = sub() { 0 }; + } +} + +use Test2::Util::Trace(); + +use Test2::Hub::Subtest(); +use Test2::Hub::Interceptor(); +use Test2::Hub::Interceptor::Terminator(); + +use Test2::Event::Ok(); +use Test2::Event::Diag(); +use Test2::Event::Note(); +use Test2::Event::Plan(); +use Test2::Event::Bail(); +use Test2::Event::Exception(); +use Test2::Event::Waiting(); +use Test2::Event::Skip(); +use Test2::Event::Subtest(); + +use Carp qw/carp croak confess longmess/; +use Scalar::Util qw/blessed weaken/; +use Test2::Util qw/get_tid/; + +our @EXPORT_OK = qw{ + context release + context_do + no_context + intercept + run_subtest + + test2_init_done + test2_load_done + + test2_set_is_end + test2_get_is_end + + test2_pid + test2_tid + test2_stack + test2_no_wait + + test2_add_callback_context_aquire + test2_add_callback_context_acquire + test2_add_callback_context_init + test2_add_callback_context_release + test2_add_callback_exit + test2_add_callback_post_load + test2_list_context_aquire_callbacks + test2_list_context_acquire_callbacks + test2_list_context_init_callbacks + test2_list_context_release_callbacks + test2_list_exit_callbacks + test2_list_post_load_callbacks + + test2_ipc + test2_ipc_drivers + test2_ipc_add_driver + test2_ipc_polling + test2_ipc_disable_polling + test2_ipc_enable_polling + test2_ipc_get_pending + test2_ipc_set_pending + test2_ipc_enable_shm + + test2_formatter + test2_formatters + test2_formatter_add + test2_formatter_set +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $STACK = $INST->stack; +my $CONTEXTS = $INST->contexts; +my $INIT_CBS = $INST->context_init_callbacks; +my $ACQUIRE_CBS = $INST->context_acquire_callbacks; + +sub test2_init_done { $INST->finalized } +sub test2_load_done { $INST->loaded } + +sub test2_pid { $INST->pid } +sub test2_tid { $INST->tid } +sub test2_stack { $INST->stack } +sub test2_no_wait { + $INST->set_no_wait(@_) if @_; + $INST->no_wait; +} + +sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) } +sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) } +sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) } +sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) } +sub test2_add_callback_exit { $INST->add_exit_callback(@_) } +sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) } +sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} } +sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} } +sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} } +sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} } +sub test2_list_exit_callbacks { @{$INST->exit_callbacks} } +sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} } + +sub test2_ipc { $INST->ipc } +sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) } +sub test2_ipc_drivers { @{$INST->ipc_drivers} } +sub test2_ipc_polling { $INST->ipc_polling } +sub test2_ipc_enable_polling { $INST->enable_ipc_polling } +sub test2_ipc_disable_polling { $INST->disable_ipc_polling } +sub test2_ipc_get_pending { $INST->get_ipc_pending } +sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } +sub test2_ipc_enable_shm { $INST->ipc_enable_shm } + +sub test2_formatter { $INST->formatter } +sub test2_formatters { @{$INST->formatters} } +sub test2_formatter_add { $INST->add_formatter(@_) } +sub test2_formatter_set { + my ($formatter) = @_; + croak "No formatter specified" unless $formatter; + croak "Global Formatter already set" if $INST->formatter_set; + $INST->set_formatter($formatter); +} + +# Private, for use in Test2::API::Context +sub _contexts_ref { $INST->contexts } +sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks } +sub _context_init_callbacks_ref { $INST->context_init_callbacks } +sub _context_release_callbacks_ref { $INST->context_release_callbacks } + +# Private, for use in Test2::IPC +sub _set_ipc { $INST->set_ipc(@_) } + +sub context_do(&;@) { + my $code = shift; + my @args = @_; + + my $ctx = context(level => 1); + + my $want = wantarray; + + my @out; + my $ok = eval { + $want ? @out = $code->($ctx, @args) : + defined($want) ? $out[0] = $code->($ctx, @args) : + $code->($ctx, @args) ; + 1; + }; + my $err = $@; + + $ctx->release; + + die $err unless $ok; + + return @out if $want; + return $out[0] if defined $want; + return; +} + +sub no_context(&;$) { + my ($code, $hid) = @_; + $hid ||= $STACK->top->hid; + + my $ctx = $CONTEXTS->{$hid}; + delete $CONTEXTS->{$hid}; + my $ok = eval { $code->(); 1 }; + my $err = $@; + + $CONTEXTS->{$hid} = $ctx; + weaken($CONTEXTS->{$hid}); + + die $err unless $ok; + + return; +}; + +my $CID = 1; +sub context { + # We need to grab these before anything else to ensure they are not + # changed. + my ($errno, $eval_error, $child_error) = (0 + $!, $@, $?); + + my %params = (level => 0, wrapped => 0, @_); + + # If something is getting a context then the sync system needs to be + # considered loaded... + $INST->load unless $INST->{loaded}; + + croak "context() called, but return value is ignored" + unless defined wantarray; + + my $stack = $params{stack} || $STACK; + my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); + my $hid = $hub->{hid}; + my $current = $CONTEXTS->{$hid}; + + $_->(\%params) for @$ACQUIRE_CBS; + map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire}; + + # This is for https://github.com/Test-More/test-more/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + my $phase = ${^GLOBAL_PHASE} || 'NA'; + my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT'; + + my $level = 1 + $params{level}; + my ($pkg, $file, $line, $sub) = $end_phase ? caller(0) : caller($level); + unless ($pkg || $end_phase) { + confess "Could not find context at depth $level" unless $params{fudge}; + ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg); + } + + my $depth = $level; + $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1); + $depth -= $params{wrapped}; + my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth; + + if ($current && $params{on_release} && $depth_ok) { + $current->{_on_release} ||= []; + push @{$current->{_on_release}} => $params{on_release}; + } + + # I know this is ugly.... + ($!, $@, $?) = ($errno, $eval_error, $child_error) and return bless( + { + %$current, + _is_canon => undef, + errno => $errno, + eval_error => $eval_error, + child_error => $child_error, + _is_spawn => [$pkg, $file, $line, $sub], + }, + 'Test2::API::Context' + ) if $current && $depth_ok; + + # Handle error condition of bad level + if ($current) { + unless (${$current->{_aborted}}) { + _canon_error($current, [$pkg, $file, $line, $sub, $depth]) + unless $current->{_is_canon}; + + _depth_error($current, [$pkg, $file, $line, $sub, $depth]) + unless $depth_ok; + } + + $current->release if $current->{_is_canon}; + + delete $CONTEXTS->{$hid}; + } + + # Directly bless the object here, calling new is a noticeable performance + # hit with how often this needs to be called. + my $trace = bless( + { + frame => [$pkg, $file, $line, $sub], + pid => $$, + tid => get_tid(), + cid => 'C' . $CID++, + }, + 'Test2::Util::Trace' + ); + + # Directly bless the object here, calling new is a noticeable performance + # hit with how often this needs to be called. + my $aborted = 0; + $current = bless( + { + _aborted => \$aborted, + stack => $stack, + hub => $hub, + trace => $trace, + _is_canon => 1, + _depth => $depth, + errno => $errno, + eval_error => $eval_error, + child_error => $child_error, + $params{on_release} ? (_on_release => [$params{on_release}]) : (), + }, + 'Test2::API::Context' + ); + + $CONTEXTS->{$hid} = $current; + weaken($CONTEXTS->{$hid}); + + $_->($current) for @$INIT_CBS; + map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init}; + + $params{on_init}->($current) if $params{on_init}; + + ($!, $@, $?) = ($errno, $eval_error, $child_error); + + return $current; +} + +sub _depth_error { + _existing_error(@_, <<" EOT"); +context() was called to retrieve an existing context, however the existing +context was created in a stack frame at the same, or deeper level. This usually +means that a tool failed to release the context when it was finished. + EOT +} + +sub _canon_error { + _existing_error(@_, <<" EOT"); +context() was called to retrieve an existing context, however the existing +context has an invalid internal state (!_canon_count). This should not normally +happen unless something is mucking about with internals... + EOT +} + +sub _existing_error { + my ($ctx, $details, $msg) = @_; + my ($pkg, $file, $line, $sub, $depth) = @$details; + + my $oldframe = $ctx->{trace}->frame; + my $olddepth = $ctx->{_depth}; + + my $mess = longmess(); + + warn <<" EOT"; +$msg +Old context details: + File: $oldframe->[1] + Line: $oldframe->[2] + Tool: $oldframe->[3] + Depth: $olddepth + +New context details: + File: $file + Line: $line + Tool: $sub + Depth: $depth + +Trace: $mess + +Removing the old context and creating a new one... + EOT +} + +sub release($;$) { + $_[0]->release; + return $_[1]; +} + +sub intercept(&) { + my $code = shift; + + my $ctx = context(); + + my $ipc; + if (my $global_ipc = test2_ipc()) { + my $driver = blessed($global_ipc); + $ipc = $driver->new; + } + + my $hub = Test2::Hub::Interceptor->new( + ipc => $ipc, + no_ending => 1, + ); + + my @events; + $hub->listen(sub { push @events => $_[1] }); + + $ctx->stack->top; # Make sure there is a top hub before we begin. + $ctx->stack->push($hub); + + my ($ok, $err) = (1, undef); + T2_SUBTEST_WRAPPER: { + # Do not use 'try' cause it localizes __DIE__ + $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 }; + $err = $@; + + # They might have done 'BEGIN { skip_all => "whatever" }' + if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) { + $ok = 1; + $err = undef; + } + } + + $hub->cull; + $ctx->stack->pop($hub); + + my $trace = $ctx->trace; + $ctx->release; + + die $err unless $ok; + + $hub->finalize($trace, 1) + if $ok + && !$hub->no_ending + && !$hub->ended; + + return \@events; +} + +sub run_subtest { + my ($name, $code, $params, @args) = @_; + + $params = {buffered => $params} unless ref $params; + my $buffered = delete $params->{buffered}; + my $inherit_trace = delete $params->{inherit_trace}; + + my $ctx = context(); + + $ctx->note($name) unless $buffered; + + my $parent = $ctx->hub; + + my $stack = $ctx->stack || $STACK; + my $hub = $stack->new_hub( + class => 'Test2::Hub::Subtest', + %$params, + ); + + my @events; + $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 ); + $hub->listen(sub { push @events => $_[1] }); + + if ($buffered) { + if (my $format = $hub->format) { + my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1; + $hub->format(undef) if $hide; + } + } + elsif (! $parent->format) { + # If our parent has no format that means we're in a buffered subtest + # and now we're trying to run a streaming subtest. There's really no + # way for that to work, so we need to force the use of a buffered + # subtest here as + # well. https://github.com/Test-More/test-more/issues/721 + $buffered = 1; + } + + if ($inherit_trace) { + my $orig = $code; + $code = sub { + my $st_ctx = Test2::API::Context->new( + trace => $ctx->trace, + hub => $hub, + ); + $st_ctx->do_in_context($orig, @args); + }; + } + + my ($ok, $err, $finished); + T2_SUBTEST_WRAPPER: { + # Do not use 'try' cause it localizes __DIE__ + $ok = eval { $code->(@args); 1 }; + $err = $@; + + # They might have done 'BEGIN { skip_all => "whatever" }' + if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { + $ok = undef; + $err = undef; + } + else { + $finished = 1; + } + } + + if ($params->{no_fork}) { + if ($$ != $ctx->trace->pid) { + warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; + exit 255; + } + + if (get_tid() != $ctx->trace->tid) { + warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err; + exit 255; + } + } + elsif (!$parent->is_local && !$parent->ipc) { + warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err; + exit 255; + } + + $stack->pop($hub); + + my $trace = $ctx->trace; + + if (!$finished) { + if(my $bailed = $hub->bailed_out) { + $ctx->bail($bailed->reason); + } + my $code = $hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } + + $hub->finalize($trace, 1) + if $ok + && !$hub->no_ending + && !$hub->ended; + + my $pass = $ok && $hub->is_passing; + my $e = $ctx->build_event( + 'Subtest', + pass => $pass, + name => $name, + subtest_id => $hub->id, + buffered => $buffered, + subevents => \@events, + ); + + my $plan_ok = $hub->check_plan; + + $ctx->hub->send($e); + + $ctx->failure_diag($e) unless $e->pass; + + $ctx->diag("Caught exception in subtest: $err") unless $ok; + + $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) + if defined($plan_ok) && !$plan_ok; + + $ctx->release; + return $pass; +} + +# There is a use-cycle between API and API/Context. Context needs to use some +# API functions as the package is compiling. Test2::API::context() needs +# Test2::API::Context to be loaded, but we cannot 'require' the module there as +# it causes a very noticeable performance impact with how often context() is +# called. +require Test2::API::Context; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API - Primary interface for writing Test2 based testing tools. + +=head1 ***INTERNALS NOTE*** + +B The public +methods provided will not change in backwards-incompatible ways (once there is +a stable release), but the underlying implementation details might. +B + +Currently the implementation is to create a single instance of the +L Object. All class methods defer to the single +instance. There is no public access to the singleton, and that is intentional. +The class methods provided by this package provide the only functionality +publicly exposed. + +This is done primarily to avoid the problems Test::Builder had by exposing its +singleton. We do not want anyone to replace this singleton, rebless it, or +directly muck with its internals. If you need to do something and cannot +because of the restrictions placed here, then please report it as an issue. If +possible, we will create a way for you to implement your functionality without +exposing things that should not be exposed. + +=head1 DESCRIPTION + +This package exports all the functions necessary to write and/or verify testing +tools. Using these building blocks you can begin writing test tools very +quickly. You are also provided with tools that help you to test the tools you +write. + +=head1 SYNOPSIS + +=head2 WRITING A TOOL + +The C method is your primary interface into the Test2 framework. + + package My::Ok; + use Test2::API qw/context/; + + our @EXPORT = qw/my_ok/; + use base 'Exporter'; + + # Just like ok() from Test::More + sub my_ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); # Get a context + $ctx->ok($bool, $name); + $ctx->release; # Release the context + return $bool; + } + +See L for a list of methods available on the context object. + +=head2 TESTING YOUR TOOLS + +The C tool lets you temporarily intercept all events +generated by the test system: + + use Test2::API qw/intercept/; + + use My::Ok qw/my_ok/; + + my $events = intercept { + # These events are not displayed + my_ok(1, "pass"); + my_ok(0, "fail"); + }; + + my_ok(@$events == 2, "got 2 events, the pass and the fail"); + my_ok($events->[0]->pass, "first event passed"); + my_ok(!$events->[1]->pass, "second event failed"); + +=head2 OTHER API FUNCTIONS + + use Test2::API qw{ + test2_init_done + test2_stack + test2_set_is_end + test2_get_is_end + test2_ipc + test2_formatter_set + test2_formatter + }; + + my $init = test2_init_done(); + my $stack = test2_stack(); + my $ipc = test2_ipc(); + + test2_formatter_set($FORMATTER) + my $formatter = test2_formatter(); + + ... And others ... + +=head1 MAIN API EXPORTS + +All exports are optional. You must specify subs to import. + + use Test2::API qw/context intercept run_subtest/; + +This is the list of exports that are most commonly needed. If you are simply +writing a tool, then this is probably all you need. If you need something and +you cannot find it here, then you can also look at L. + +These exports lack the 'test2_' prefix because of how important/common they +are. Exports in the L section have the 'test2_' prefix to +ensure they stand out. + +=head2 context(...) + +Usage: + +=over 4 + +=item $ctx = context() + +=item $ctx = context(%params) + +=back + +The C function will always return the current context. If +there is already a context active, it will be returned. If there is not an +active context, one will be generated. When a context is generated it will +default to using the file and line number where the currently running sub was +called from. + +Please see L for important rules about +what you can and cannot do with a context once it is obtained. + +B This function will throw an exception if you ignore the context object +it returns. + +B On perls 5.14+ a depth check is used to insure there are no context +leaks. This cannot be safely done on older perls due to +L +You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or +C<$Test2::API::DO_DEPTH_CHECK = 1> B loading L. + +=head3 OPTIONAL PARAMETERS + +All parameters to C are optional. + +=over 4 + +=item level => $int + +If you must obtain a context in a sub deeper than your entry point you can use +this to tell it how many EXTRA stack frames to look back. If this option is not +provided the default of C<0> is used. + + sub third_party_tool { + my $sub = shift; + ... # Does not obtain a context + $sub->(); + ... + } + + third_party_tool(sub { + my $ctx = context(level => 1); + ... + $ctx->release; + }); + +=item wrapped => $int + +Use this if you need to write your own tool that wraps a call to C +with the intent that it should return a context object. + + sub my_context { + my %params = ( wrapped => 0, @_ ); + $params{wrapped}++; + my $ctx = context(%params); + ... + return $ctx; + } + + sub my_tool { + my $ctx = my_context(); + ... + $ctx->release; + } + +If you do not do this, then tools you call that also check for a context will +notice that the context they grabbed was created at the same stack depth, which +will trigger protective measures that warn you and destroy the existing +context. + +=item stack => $stack + +Normally C looks at the global hub stack. If you are maintaining +your own L instance you may pass it in to be used +instead of the global one. + +=item hub => $hub + +Use this parameter if you want to obtain the context for a specific hub instead +of whatever one happens to be at the top of the stack. + +=item on_init => sub { ... } + +This lets you provide a callback sub that will be called B if your call +to C generated a new context. The callback B be called if +C is returning an existing context. The only argument passed into +the callback will be the context object itself. + + sub foo { + my $ctx = context(on_init => sub { 'will run' }); + + my $inner = sub { + # This callback is not run since we are getting the existing + # context from our parent sub. + my $ctx = context(on_init => sub { 'will NOT run' }); + $ctx->release; + } + $inner->(); + + $ctx->release; + } + +=item on_release => sub { ... } + +This lets you provide a callback sub that will be called when the context +instance is released. This callback will be added to the returned context even +if an existing context is returned. If multiple calls to context add callbacks, +then all will be called in reverse order when the context is finally released. + + sub foo { + my $ctx = context(on_release => sub { 'will run second' }); + + my $inner = sub { + my $ctx = context(on_release => sub { 'will run first' }); + + # Neither callback runs on this release + $ctx->release; + } + $inner->(); + + # Both callbacks run here. + $ctx->release; + } + +=back + +=head2 release($;$) + +Usage: + +=over 4 + +=item release $ctx; + +=item release $ctx, ...; + +=back + +This is intended as a shortcut that lets you release your context and return a +value in one statement. This function will get your context, and an optional +return value. It will release your context, then return your value. Scalar +context is always assumed. + + sub tool { + my $ctx = context(); + ... + + return release $ctx, 1; + } + +This tool is most useful when you want to return the value you get from calling +a function that needs to see the current context: + + my $ctx = context(); + my $out = some_tool(...); + $ctx->release; + return $out; + +We can combine the last 3 lines of the above like so: + + my $ctx = context(); + release $ctx, some_tool(...); + +=head2 context_do(&;@) + +Usage: + + sub my_tool { + context_do { + my $ctx = shift; + + my (@args) = @_; + + $ctx->ok(1, "pass"); + + ... + + # No need to call $ctx->release, done for you on scope exit. + } @_; + } + +Using this inside your test tool takes care of a lot of boilerplate for you. It +will ensure a context is acquired. It will capture and rethrow any exception. It +will insure the context is released when you are done. It preserves the +subroutine call context (array, scalar, void). + +This is the safest way to write a test tool. The only two downsides to this are a +slight performance decrease, and some extra indentation in your source. If the +indentation is a problem for you then you can take a peek at the next section. + +=head2 no_context(&;$) + +Usage: + +=over 4 + +=item no_context { ... }; + +=item no_context { ... } $hid; + + sub my_tool(&) { + my $code = shift; + my $ctx = context(); + ... + + no_context { + # Things in here will not see our current context, they get a new + # one. + + $code->(); + }; + + ... + $ctx->release; + }; + +=back + +This tool will hide a context for the provided block of code. This means any +tools run inside the block will get a completely new context if they acquire +one. The new context will be inherited by tools nested below the one that +acquired it. + +This will normally hide the current context for the top hub. If you need to +hide the context for a different hub you can pass in the optional C<$hid> +parameter. + +=head2 intercept(&) + +Usage: + + my $events = intercept { + ok(1, "pass"); + ok(0, "fail"); + ... + }; + +This function takes a codeblock as its only argument, and it has a prototype. +It will execute the codeblock, intercepting any generated events in the +process. It will return an array reference with all the generated event +objects. All events should be subclasses of L. + +This is a very low-level subtest tool. This is useful for writing tools which +produce subtests. This is not intended for people simply writing tests. + +=head2 run_subtest(...) + +Usage: + + run_subtest($NAME, \&CODE, $BUFFERED, @ARGS) + + # or + + run_subtest($NAME, \&CODE, \%PARAMS, @ARGS) + +This will run the provided codeblock with the args in C<@args>. This codeblock +will be run as a subtest. A subtest is an isolated test state that is condensed +into a single L event, which contains all events +generated inside the subtest. + +=head3 ARGUMENTS: + +=over 4 + +=item $NAME + +The name of the subtest. + +=item \&CODE + +The code to run inside the subtest. + +=item $BUFFERED or \%PARAMS + +If this is a simple scalar then it will be treated as a boolean for the +'buffered' setting. If this is a hash reference then it will be used as a +parameters hash. The param hash will be used for hub construction (with the +specified keys removed). + +Keys that are removed and used by run_subtest: + +=over 4 + +=item 'buffered' => $bool + +Toggle buffered status. + +=item 'inherit_trace' => $bool + +Normally the subtest hub is pushed and the sub is allowed to generate its own +root context for the hub. When this setting is turned on a root context will be +created for the hub that shares the same trace as the current context. + +Set this to true if your tool is producing subtests without user-specified +subs. + +=item 'no_fork' => $bool + +Defaults to off. Normally forking inside a subtest will actually fork the +subtest, resulting in 2 final subtest events. This parameter will turn off that +behavior, only the original process/thread will return a final subtest event. + +=back + +=item @ARGS + +Any extra arguments you want passed into the subtest code. + +=back + +=head3 BUFFERED VS UNBUFFERED (OR STREAMED) + +Normally all events inside and outside a subtest are sent to the formatter +immediately by the hub. Sometimes it is desirable to hold off sending events +within a subtest until the subtest is complete. This usually depends on the +formatter being used. + +=over 4 + +=item Things not effected by this flag + +In both cases events are generated and stored in an array. This array is +eventually used to populate the C attribute on the +L event that is generated at the end of the subtest. +This flag has no effect on this part, it always happens. + +At the end of the subtest, the final L event is sent to +the formatter. + +=item Things that are effected by this flag + +The C attribute of the L event will be set to +the value of this flag. This means any formatter, listener, etc which looks at +the event will know if it was buffered. + +=item Things that are formatter dependant + +Events within a buffered subtest may or may not be sent to the formatter as +they happen. If a formatter fails to specify then the default is to B +the events as they are generated, instead the formatter can pull them from the +C attribute. + +A formatter can specify by implementing the C method. If this +method returns true then events generated inside a buffered subtest will not be +sent independently of the final subtest event. + +=back + +An example of how this is used is the L formatter. For +unbuffered subtests the events are rendered as they are generated. At the end +of the subtest, the final subtest event is rendered, but the C +attribute is ignored. For buffered subtests the opposite occurs, the events are +NOT rendered as they are generated, instead the C attribute is used +to render them all at once. This is useful when running subtests tests in +parallel, since without it the output from subtests would be interleaved +together. + +=head1 OTHER API EXPORTS + +Exports in this section are not commonly needed. These all have the 'test2_' +prefix to help ensure they stand out. You should look at the L section before looking here. This section is one where "Great power +comes with great responsibility". It is possible to break things badly if you +are not careful with these. + +All exports are optional. You need to list which ones you want at import time: + + use Test2::API qw/test2_init_done .../; + +=head2 STATUS AND INITIALIZATION STATE + +These provide access to internal state and object instances. + +=over 4 + +=item $bool = test2_init_done() + +This will return true if the stack and IPC instances have already been +initialized. It will return false if they have not. Init happens as late as +possible. It happens as soon as a tool requests the IPC instance, the +formatter, or the stack. + +=item $bool = test2_load_done() + +This will simply return the boolean value of the loaded flag. If Test2 has +finished loading this will be true, otherwise false. Loading is considered +complete the first time a tool requests a context. + +=item test2_set_is_end() + +=item test2_set_is_end($bool) + +This is used to toggle Test2's belief that the END phase has already started. +With no arguments this will set it to true. With arguments it will set it to +the first argument's value. + +This is used to prevent the use of C in END blocks which can cause +segfaults. This is only necessary in some persistent environments that may have +multiple END phases. + +=item $bool = test2_get_is_end() + +Check if Test2 believes it is the END phase. + +=item $stack = test2_stack() + +This will return the global L instance. If this has not +yet been initialized it will be initialized now. + +=item $bool = test2_no_wait() + +=item test2_no_wait($bool) + +This can be used to get/set the no_wait status. Waiting is turned on by +default. Waiting will cause the parent process/thread to wait until all child +processes and threads are finished before exiting. You will almost never want +to turn this off. + +=back + +=head2 BEHAVIOR HOOKS + +These are hooks that allow you to add custom behavior to actions taken by Test2 +and tools built on top of it. + +=over 4 + +=item test2_add_callback_exit(sub { ... }) + +This can be used to add a callback that is called after all testing is done. This +is too late to add additional results, the main use of this callback is to set the +exit code. + + test2_add_callback_exit( + sub { + my ($context, $exit, \$new_exit) = @_; + ... + } + ); + +The C<$context> passed in will be an instance of L. The +C<$exit> argument will be the original exit code before anything modified it. +C<$$new_exit> is a reference to the new exit code. You may modify this to +change the exit code. Please note that C<$$new_exit> may already be different +from C<$exit> + +=item test2_add_callback_post_load(sub { ... }) + +Add a callback that will be called when Test2 is finished loading. This +means the callback will be run once, the first time a context is obtained. +If Test2 has already finished loading then the callback will be run immediately. + +=item test2_add_callback_context_acquire(sub { ... }) + +Add a callback that will be called every time someone tries to acquire a +context. This will be called on EVERY call to C. It gets a single +argument, a reference to the hash of parameters being used the construct the +context. This is your chance to change the parameters by directly altering the +hash. + + test2_add_callback_context_acquire(sub { + my $params = shift; + $params->{level}++; + }); + +This is a very scary API function. Please do not use this unless you need to. +This is here for L and backwards compatibility. This has you +directly manipulate the hash instead of returning a new one for performance +reasons. + +=item test2_add_callback_context_init(sub { ... }) + +Add a callback that will be called every time a new context is created. The +callback will receive the newly created context as its only argument. + +=item test2_add_callback_context_release(sub { ... }) + +Add a callback that will be called every time a context is released. The +callback will receive the released context as its only argument. + +=item @list = test2_list_context_acquire_callbacks() + +Return all the context acquire callback references. + +=item @list = test2_list_context_init_callbacks() + +Returns all the context init callback references. + +=item @list = test2_list_context_release_callbacks() + +Returns all the context release callback references. + +=item @list = test2_list_exit_callbacks() + +Returns all the exit callback references. + +=item @list = test2_list_post_load_callbacks() + +Returns all the post load callback references. + +=back + +=head2 IPC AND CONCURRENCY + +These let you access, or specify, the IPC system internals. + +=over 4 + +=item $ipc = test2_ipc() + +This will return the global L instance. If this has not yet +been initialized it will be initialized now. + +=item test2_ipc_add_driver($DRIVER) + +Add an IPC driver to the list. This will add the driver to the start of the +list. + +=item @drivers = test2_ipc_drivers() + +Get the list of IPC drivers. + +=item $bool = test2_ipc_polling() + +Check if polling is enabled. + +=item test2_ipc_enable_polling() + +Turn on polling. This will cull events from other processes and threads every +time a context is created. + +=item test2_ipc_disable_polling() + +Turn off IPC polling. + +=item test2_ipc_enable_shm() + +Turn on IPC SHM. Only some IPC drivers use this, and most will turn it on +themselves. + +=item test2_ipc_set_pending($uniq_val) + +Tell other processes and events that an event is pending. C<$uniq_val> should +be a unique value no other thread/process will generate. + +B After calling this C will return 1. This is +intentional, and not avoidable. + +=item $pending = test2_ipc_get_pending() + +This returns -1 if there is no way to check (assume yes) + +This returns 0 if there are (most likely) no pending events. + +This returns 1 if there are (likely) pending events. Upon return it will reset, +nothing else will be able to see that there were pending events. + +=back + +=head2 MANAGING FORMATTERS + +These let you access, or specify, the formatters that can/should be used. + +=over 4 + +=item $formatter = test2_formatter + +This will return the global formatter class. This is not an instance. By +default the formatter is set to L. + +You can override this default using the C environment variable. + +Normally 'Test2::Formatter::' is prefixed to the value in the +environment variable: + + $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter + $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter + +If you want to specify a full module name you use the '+' prefix: + + $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter + +=item test2_formatter_set($class_or_instance) + +Set the global formatter class. This can only be set once. B This will +override anything specified in the 'T2_FORMATTER' environment variable. + +=item @formatters = test2_formatters() + +Get a list of all loaded formatters. + +=item test2_formatter_add($class_or_instance) + +Add a formatter to the list. Last formatter added is used at initialization. If +this is called after initialization a warning will be issued. + +=back + +=head1 OTHER EXAMPLES + +See the C directory included in this distribution. + +=head1 SEE ALSO + +L - Detailed documentation of the context object. + +L - The IPC system used for threading/fork support. + +L - Formatters such as TAP live here. + +L - Events live in this namespace. + +L - All events eventually funnel through a hub. Custom hubs are how +C and C are implemented. + +=head1 MAGIC + +This package has an END block. This END block is responsible for setting the +exit code based on the test results. This end block also calls the callbacks that +can be added to this package. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/API/Breakage.pm b/dist/Test-Simple/lib/Test2/API/Breakage.pm new file mode 100644 index 00000000000..c99c3b22177 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/API/Breakage.pm @@ -0,0 +1,175 @@ +package Test2::API::Breakage; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Test2::Util qw/pkg_to_file/; + +our @EXPORT_OK = qw{ + upgrade_suggested + upgrade_required + known_broken +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub upgrade_suggested { + return ( + 'Test::Exception' => '0.42', + 'Test::FITesque' => '0.04', + 'Test::Module::Used' => '0.2.5', + 'Test::Moose::More' => '0.025', + ); +} + +sub upgrade_required { + return ( + 'Test::Builder::Clutch' => '0.07', + 'Test::Dist::VersionSync' => '1.1.4', + 'Test::Modern' => '0.012', + 'Test::SharedFork' => '0.34', + 'Test::Alien' => '0.04', + 'Test::UseAllModules' => '0.14', + + 'Test::Clustericious::Cluster' => '0.30', + ); +} + +sub known_broken { + return ( + 'Net::BitTorrent' => '0.052', + 'Test::Able' => '0.11', + 'Test::Aggregate' => '0.373', + 'Test::Flatten' => '0.11', + 'Test::Group' => '0.20', + 'Test::More::Prefix' => '0.005', + 'Test::ParallelSubtest' => '0.05', + 'Test::Pretty' => '0.32', + 'Test::Wrapper' => '0.3.0', + + 'Test::DBIx::Class::Schema' => '1.0.9', + 'Log::Dispatch::Config::TestLog' => '0.02', + ); +} + +# Not reportable: +# Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to. + +sub report { + my $class = shift; + my ($require) = @_; + + my %suggest = __PACKAGE__->upgrade_suggested(); + my %required = __PACKAGE__->upgrade_required(); + my %broken = __PACKAGE__->known_broken(); + + my @warn; + for my $mod (keys %suggest) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $want = $suggest{$mod}; + next if eval { $mod->VERSION($want); 1 }; + push @warn => " * Module '$mod' is outdated, we recommed updating above $want."; + } + + for my $mod (keys %required) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $want = $required{$mod}; + next if eval { $mod->VERSION($want); 1 }; + push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher."; + } + + for my $mod (keys %broken) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $tested = $broken{$mod}; + push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION; + } + + return @warn; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Breakage - What breaks at what version + +=head1 DESCRIPTION + +This module provides lists of modules that are broken, or have been broken in +the past, when upgrading L to use L. + +=head1 FUNCTIONS + +These can be imported, or called as methods on the class. + +=over 4 + +=item %mod_ver = upgrade_suggested() + +=item %mod_ver = Test2::API::Breakage->upgrade_suggested() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then an upgrade would be a good idea, but not strictly necessary. + +=item %mod_ver = upgrade_required() + +=item %mod_ver = Test2::API::Breakage->upgrade_required() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then an upgrade is required for the module to work properly. + +=item %mod_ver = known_broken() + +=item %mod_ver = Test2::API::Breakage->known_broken() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then the module will not work. A newer version may work, but is +not tested or verified. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/API/Context.pm b/dist/Test-Simple/lib/Test2/API/Context.pm new file mode 100644 index 00000000000..18875a3fa61 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/API/Context.pm @@ -0,0 +1,739 @@ +package Test2::API::Context; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Carp qw/confess croak longmess/; +use Scalar::Util qw/weaken blessed/; +use Test2::Util qw/get_tid try pkg_to_file get_tid/; + +use Test2::Util::Trace(); +use Test2::API(); + +# Preload some key event types +my %LOADED = ( + map { + my $pkg = "Test2::Event::$_"; + my $file = "Test2/Event/$_.pm"; + require $file unless $INC{$file}; + ( $pkg => $pkg, $_ => $pkg ) + } qw/Ok Diag Note Info Plan Bail Exception Waiting Skip Subtest/ +); + +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util::HashBase qw{ + stack hub trace _on_release _depth _is_canon _is_spawn _aborted + errno eval_error child_error thrown +}; + +# Private, not package vars +# It is safe to cache these. +my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); +my $CONTEXTS = Test2::API::_contexts_ref(); + +sub init { + my $self = shift; + + confess "The 'trace' attribute is required" + unless $self->{+TRACE}; + + confess "The 'hub' attribute is required" + unless $self->{+HUB}; + + $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; + + $self->{+ERRNO} = $! unless exists $self->{+ERRNO}; + $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; + $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; +} + +sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } + +sub restore_error_vars { + my $self = shift; + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; +} + +sub DESTROY { + return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; + return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; + my ($self) = @_; + + my $hub = $self->{+HUB}; + my $hid = $hub->{hid}; + + # Do not show the warning if it looks like an exception has been thrown, or + # if the context is not local to this process or thread. + { + # Sometimes $@ is uninitialized, not a problem in this case so do not + # show the warning about using eq. + no warnings 'uninitialized'; + if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { + my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; + warn <<" EOT"; +A context appears to have been destroyed without first calling release(). +Based on \$@ it does not look like an exception was thrown (this is not always +a reliable test) + +This is a problem because the global error variables (\$!, \$@, and \$?) will +not be restored. In addition some release callbacks will not work properly from +inside a DESTROY method. + +Here are the context creation details, just in case a tool forgot to call +release(): + File: $frame->[1] + Line: $frame->[2] + Tool: $frame->[3] + +Cleaning up the CONTEXT stack... + EOT + } + } + + return if $self->{+_IS_SPAWN}; + + # Remove the key itself to avoid a slow memory leak + delete $CONTEXTS->{$hid}; + $self->{+_IS_CANON} = undef; + + if (my $cbk = $self->{+_ON_RELEASE}) { + $_->($self) for reverse @$cbk; + } + if (my $hcbk = $hub->{_context_release}) { + $_->($self) for reverse @$hcbk; + } + $_->($self) for reverse @$ON_RELEASE; +} + +# release exists to implement behaviors like die-on-fail. In die-on-fail you +# want to die after a failure, but only after diagnostics have been reported. +# The ideal time for the die to happen is when the context is released. +# Unfortunately die does not work in a DESTROY block. +sub release { + my ($self) = @_; + + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN}; + + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef + if $self->{+_IS_SPAWN}; + + croak "release() should not be called on context that is neither canon nor a child" + unless $self->{+_IS_CANON}; + + my $hub = $self->{+HUB}; + my $hid = $hub->{hid}; + + croak "context thinks it is canon, but it is not" + unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; + + # Remove the key itself to avoid a slow memory leak + $self->{+_IS_CANON} = undef; + delete $CONTEXTS->{$hid}; + + if (my $cbk = $self->{+_ON_RELEASE}) { + $_->($self) for reverse @$cbk; + } + if (my $hcbk = $hub->{_context_release}) { + $_->($self) for reverse @$hcbk; + } + $_->($self) for reverse @$ON_RELEASE; + + # Do this last so that nothing else changes them. + # If one of the hooks dies then these do not get restored, this is + # intentional + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; + + return; +} + +sub do_in_context { + my $self = shift; + my ($sub, @args) = @_; + + # We need to update the pid/tid and error vars. + my $clone = $self->snapshot; + @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); + $clone->{+TRACE} = $clone->{+TRACE}->snapshot; + $clone->{+TRACE}->set_pid($$); + $clone->{+TRACE}->set_tid(get_tid()); + + my $hub = $clone->{+HUB}; + my $hid = $hub->hid; + + my $old = $CONTEXTS->{$hid}; + + $clone->{+_IS_CANON} = 1; + $CONTEXTS->{$hid} = $clone; + weaken($CONTEXTS->{$hid}); + my ($ok, $err) = &try($sub, @args); + my ($rok, $rerr) = try { $clone->release }; + delete $clone->{+_IS_CANON}; + + if ($old) { + $CONTEXTS->{$hid} = $old; + weaken($CONTEXTS->{$hid}); + } + else { + delete $CONTEXTS->{$hid}; + } + + die $err unless $ok; + die $rerr unless $rok; +} + +sub done_testing { + my $self = shift; + $self->hub->finalize($self->trace, 1); + return; +} + +sub throw { + my ($self, $msg) = @_; + $self->{+THROWN} = 1; + ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; + $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; + $self->trace->throw($msg); +} + +sub alert { + my ($self, $msg) = @_; + $self->trace->alert($msg); +} + +sub send_event { + my $self = shift; + my $event = shift; + my %args = @_; + + my $pkg = $LOADED{$event} || $self->_parse_event($event); + + my $e = $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); + + ${$self->{+_ABORTED}}++ if $self->{+_ABORTED} && defined $e->terminate; + $self->{+HUB}->send($e); +} + +sub build_event { + my $self = shift; + my $event = shift; + my %args = @_; + + my $pkg = $LOADED{$event} || $self->_parse_event($event); + + $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); +} + +sub ok { + my $self = shift; + my ($pass, $name, $on_fail) = @_; + + my $hub = $self->{+HUB}; + + my $e = bless { + trace => bless( {%{$self->{+TRACE}}}, 'Test2::Util::Trace'), + pass => $pass, + name => $name, + }, 'Test2::Event::Ok'; + $e->init; + + $hub->send($e); + return $e if $pass; + + $self->failure_diag($e); + + if ($on_fail && @$on_fail) { + for my $of (@$on_fail) { + if (ref($of) eq 'CODE' || (blessed($of) && $of->can('render'))) { + $self->info($of, diagnostics => 1); + } + else { + $self->diag($of); + } + } + } + + return $e; +} + +sub failure_diag { + my $self = shift; + my ($e) = @_; + + # This behavior is inherited from Test::Builder which injected a newline at + # the start of the first diagnostics when the harness is active, but not + # verbose. This is important to keep the diagnostics from showing up + # appended to the existing line, which is hard to read. In a verbose + # harness there is no need for this. + my $prefix = $ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_IS_VERBOSE} ? "\n" : ""; + + # Figure out the debug info, this is typically the file name and line + # number, but can also be a custom message. If no trace object is provided + # then we have nothing useful to display. + my $name = $e->name; + my $trace = $e->trace; + my $debug = $trace ? $trace->debug : "[No trace info available]"; + + # Create the initial diagnostics. If the test has a name we put the debug + # info on a second line, this behavior is inherited from Test::Builder. + my $msg = defined($name) + ? qq[${prefix}Failed test '$name'\n$debug.\n] + : qq[${prefix}Failed test $debug.\n]; + + $self->diag($msg); +} + +sub skip { + my $self = shift; + my ($name, $reason, @extra) = @_; + $self->send_event( + 'Skip', + name => $name, + reason => $reason, + pass => 1, + @extra, + ); +} + +sub info { + my $self = shift; + my ($renderer, %params) = @_; + $self->send_event('Info', renderer => $renderer, %params); +} + +sub note { + my $self = shift; + my ($message) = @_; + $self->send_event('Note', message => $message); +} + +sub diag { + my $self = shift; + my ($message) = @_; + my $hub = $self->{+HUB}; + $self->send_event( + 'Diag', + message => $message, + ); +} + +sub plan { + my ($self, $max, $directive, $reason) = @_; + $self->send_event('Plan', max => $max, directive => $directive, reason => $reason); +} + +sub bail { + my ($self, $reason) = @_; + $self->send_event('Bail', reason => $reason); +} + +sub _parse_event { + my $self = shift; + my $event = shift; + + my $pkg; + if ($event =~ m/^\+(.*)/) { + $pkg = $1; + } + else { + $pkg = "Test2::Event::$event"; + } + + unless ($LOADED{$pkg}) { + my $file = pkg_to_file($pkg); + my ($ok, $err) = try { require $file }; + $self->throw("Could not load event module '$pkg': $err") + unless $ok; + + $LOADED{$pkg} = $pkg; + } + + confess "'$pkg' is not a subclass of 'Test2::Event'" + unless $pkg->isa('Test2::Event'); + + $LOADED{$event} = $pkg; + + return $pkg; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Context - Object to represent a testing context. + +=head1 DESCRIPTION + +The context object is the primary interface for authors of testing tools +written with L. The context object represents the context in +which a test takes place (File and Line Number), and provides a quick way to +generate events from that context. The context object also takes care of +sending events to the correct L instance. + +=head1 SYNOPSIS + +In general you will not be creating contexts directly. To obtain a context you +should always use C which is exported by the L module. + + use Test2::API qw/context/; + + sub my_ok { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; # You MUST do this! + return $bool; + } + +Context objects make it easy to wrap other tools that also use context. Once +you grab a context, any tool you call before releasing your context will +inherit it: + + sub wrapper { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->diag("wrapping my_ok"); + + my $out = my_ok($bool, $name); + $ctx->release; # You MUST do this! + return $out; + } + +=head1 CRITICAL DETAILS + +=over 4 + +=item you MUST always use the context() sub from Test2::API + +Creating your own context via C<< Test2::API::Context->new() >> will almost never +produce a desirable result. Use C which is exported by L. + +There are a handful of cases where a tool author may want to create a new +context by hand, which is why the C method exists. Unless you really know +what you are doing you should avoid this. + +=item You MUST always release the context when done with it + +Releasing the context tells the system you are done with it. This gives it a +chance to run any necessary callbacks or cleanup tasks. If you forget to +release the context it will try to detect the problem and warn you about it. + +=item You MUST NOT pass context objects around + +When you obtain a context object it is made specifically for your tool and any +tools nested within. If you pass a context around you run the risk of polluting +other tools with incorrect context information. + +If you are certain that you want a different tool to use the same context you +may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of +the context that is safe to pass around or store. + +=item You MUST NOT store or cache a context for later + +As long as a context exists for a given hub, all tools that try to get a +context will get the existing instance. If you try to store the context you +will pollute other tools with incorrect context information. + +If you are certain that you want to save the context for later, you can use a +snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context +that is safe to pass around or store. + +C has some mechanisms to protect you if you do cause a context to +persist beyond the scope in which it was obtained. In practice you should not +rely on these protections, and they are fairly noisy with warnings. + +=item You SHOULD obtain your context as soon as possible in a given tool + +You never know what tools you call from within your own tool will need a +context. Obtaining the context early ensures that nested tools can find the +context you want them to find. + +=back + +=head1 METHODS + +=over 4 + +=item $ctx->done_testing; + +Note that testing is finished. If no plan has been set this will generate a +Plan event. + +=item $clone = $ctx->snapshot() + +This will return a shallow clone of the context. The shallow clone is safe to +store for later. + +=item $ctx->release() + +This will release the context. This runs cleanup tasks, and several important +hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the +context was created. + +B If a context is acquired more than once an internal refcount is kept. +C decrements the ref count, none of the other actions of +C will occur unless the refcount hits 0. This means only the last +call to C will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks. + +=item $ctx->throw($message) + +This will throw an exception reporting to the file and line number of the +context. This will also release the context for you. + +=item $ctx->alert($message) + +This will issue a warning from the file and line number of the context. + +=item $stack = $ctx->stack() + +This will return the L instance the context used to find +the current hub. + +=item $hub = $ctx->hub() + +This will return the L instance the context recognizes as the +current one to which all events should be sent. + +=item $dbg = $ctx->trace() + +This will return the L instance used by the context. + +=item $ctx->do_in_context(\&code, @args); + +Sometimes you have a context that is not current, and you want things to use it +as the current one. In these cases you can call +C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and +anything inside of it that looks for a context will find the one on which the +method was called. + +This B affect context on other hubs, only the hub used by the context +will be affected. + + my $ctx = ...; + $ctx->do_in_context(sub { + my $ctx = context(); # returns the $ctx the sub is called on + }); + +B The context will actually be cloned, the clone will be used instead of +the original. This allows the thread id, process id, and error variables to be correct without +modifying the original context. + +=item $ctx->restore_error_vars() + +This will set C<$!>, C<$?>, and C<$@> to what they were when the context was +created. There is no localization or anything done here, calling this method +will actually set these vars. + +=item $! = $ctx->errno() + +The (numeric) value of C<$!> when the context was created. + +=item $? = $ctx->child_error() + +The value of C<$?> when the context was created. + +=item $@ = $ctx->eval_error() + +The value of C<$@> when the context was created. + +=back + +=head2 EVENT PRODUCTION METHODS + +=over 4 + +=item $event = $ctx->ok($bool, $name) + +=item $event = $ctx->ok($bool, $name, \@on_fail) + +This will create an L object for you. If C<$bool> is false +then an L event will be sent as well with details about the +failure. If you do not want automatic diagnostics you should use the +C method directly. + +The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in +the event of a test failure. Plain strings will be sent as +L events. References will be used to construct +L events with C<< diagnostics => 1 >>. + +=item $event = $ctx->info($renderer, diagnostics => $bool, %other_params) + +Send an L. + +=item $event = $ctx->note($message) + +Send an L. This event prints a message to STDOUT. + +=item $event = $ctx->diag($message) + +Send an L. This event prints a message to STDERR. + +=item $event = $ctx->plan($max) + +=item $event = $ctx->plan(0, 'SKIP', $reason) + +This can be used to send an L event. This event +usually takes either a number of tests you expect to run. Optionally you can +set the expected count to 0 and give the 'SKIP' directive with a reason to +cause all tests to be skipped. + +=item $event = $ctx->skip($name, $reason); + +Send an L event. + +=item $event = $ctx->bail($reason) + +This sends an L event. This event will completely +terminate all testing. + +=item $event = $ctx->send_event($Type, %parameters) + +This lets you build and send an event of any type. The C<$Type> argument should +be the event package name with C left off, or a fully +qualified package name prefixed with a '+'. The event is returned after it is +sent. + + my $event = $ctx->send_event('Ok', ...); + +or + + my $event = $ctx->send_event('+Test2::Event::Ok', ...); + +=item $event = $ctx->build_event($Type, %parameters) + +This is the same as C, except it builds and returns the event +without sending it. + +=back + +=head1 HOOKS + +There are 2 types of hooks, init hooks, and release hooks. As the names +suggest, these hooks are triggered when contexts are created or released. + +=head2 INIT HOOKS + +These are called whenever a context is initialized. That means when a new +instance is created. These hooks are B called every time something +requests a context, just when a new one is created. + +=head3 GLOBAL + +This is how you add a global init callback. Global callbacks happen for every +context for any hub or stack. + + Test2::API::test2_add_callback_context_init(sub { + my $ctx = shift; + ... + }); + +=head3 PER HUB + +This is how you add an init callback for all contexts created for a given hub. +These callbacks will not run for other hubs. + + $hub->add_context_init(sub { + my $ctx = shift; + ... + }); + +=head3 PER CONTEXT + +This is how you specify an init hook that will only run if your call to +C generates a new context. The callback will be ignored if +C is returning an existing context. + + my $ctx = context(on_init => sub { + my $ctx = shift; + ... + }); + +=head2 RELEASE HOOKS + +These are called whenever a context is released. That means when the last +reference to the instance is about to be destroyed. These hooks are B +called every time C<< $ctx->release >> is called. + +=head3 GLOBAL + +This is how you add a global release callback. Global callbacks happen for every +context for any hub or stack. + + Test2::API::test2_add_callback_context_release(sub { + my $ctx = shift; + ... + }); + +=head3 PER HUB + +This is how you add a release callback for all contexts created for a given +hub. These callbacks will not run for other hubs. + + $hub->add_context_release(sub { + my $ctx = shift; + ... + }); + +=head3 PER CONTEXT + +This is how you add release callbacks directly to a context. The callback will +B be added to the context that gets returned, it does not matter if a +new one is generated, or if an existing one is returned. + + my $ctx = context(on_release => sub { + my $ctx = shift; + ... + }); + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/API/Instance.pm b/dist/Test-Simple/lib/Test2/API/Instance.pm new file mode 100644 index 00000000000..ea32d30b881 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/API/Instance.pm @@ -0,0 +1,754 @@ +package Test2::API::Instance; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; +use Carp qw/confess carp/; +use Scalar::Util qw/reftype/; + +use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/; + +use Test2::Util::Trace(); +use Test2::API::Stack(); + +use Test2::Util::HashBase qw{ + _pid _tid + no_wait + finalized loaded + ipc stack formatter + contexts + + ipc_shm_size + ipc_shm_last + ipc_shm_id + ipc_polling + ipc_drivers + formatters + + exit_callbacks + post_load_callbacks + context_acquire_callbacks + context_init_callbacks + context_release_callbacks +}; + +sub pid { $_[0]->{+_PID} ||= $$ } +sub tid { $_[0]->{+_TID} ||= get_tid() } + +# Wrap around the getters that should call _finalize. +BEGIN { + for my $finalizer (IPC, FORMATTER) { + my $orig = __PACKAGE__->can($finalizer); + my $new = sub { + my $self = shift; + $self->_finalize unless $self->{+FINALIZED}; + $self->$orig; + }; + + no strict 'refs'; + no warnings 'redefine'; + *{$finalizer} = $new; + } +} + +sub import { + my $class = shift; + return unless @_; + my ($ref) = @_; + $$ref = $class->new; +} + +sub init { $_[0]->reset } + +sub reset { + my $self = shift; + + delete $self->{+_PID}; + delete $self->{+_TID}; + + $self->{+CONTEXTS} = {}; + + $self->{+IPC_DRIVERS} = []; + $self->{+IPC_POLLING} = undef; + + $self->{+FORMATTERS} = []; + $self->{+FORMATTER} = undef; + + $self->{+FINALIZED} = undef; + $self->{+IPC} = undef; + + $self->{+NO_WAIT} = 0; + $self->{+LOADED} = 0; + + $self->{+EXIT_CALLBACKS} = []; + $self->{+POST_LOAD_CALLBACKS} = []; + $self->{+CONTEXT_ACQUIRE_CALLBACKS} = []; + $self->{+CONTEXT_INIT_CALLBACKS} = []; + $self->{+CONTEXT_RELEASE_CALLBACKS} = []; + + $self->{+STACK} = Test2::API::Stack->new; +} + +sub _finalize { + my $self = shift; + my ($caller) = @_; + $caller ||= [caller(1)]; + + $self->{+FINALIZED} = $caller; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + unless ($self->{+FORMATTER}) { + my ($formatter, $source); + if ($ENV{T2_FORMATTER}) { + $source = "set by the 'T2_FORMATTER' environment variable"; + + if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { + $formatter = $1 ? $2 : "Test2::Formatter::$2" + } + else { + $formatter = ''; + } + } + elsif (@{$self->{+FORMATTERS}}) { + ($formatter) = @{$self->{+FORMATTERS}}; + $source = "Most recently added"; + } + else { + $formatter = 'Test2::Formatter::TAP'; + $source = 'default formatter'; + } + + unless (ref($formatter) || $formatter->can('write')) { + my $file = pkg_to_file($formatter); + my ($ok, $err) = try { require $file }; + unless ($ok) { + my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *"; + my $border = '*' x length($line); + die "\n\n $border\n $line\n $border\n\n$err"; + } + } + + $self->{+FORMATTER} = $formatter; + } + + # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC + # module is loaded. + return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}}; + + # Turn on polling by default, people expect it. + $self->enable_ipc_polling; + + unless (@{$self->{+IPC_DRIVERS}}) { + my ($ok, $error) = try { require Test2::IPC::Driver::Files }; + die $error unless $ok; + push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files'; + } + + for my $driver (@{$self->{+IPC_DRIVERS}}) { + next unless $driver->can('is_viable') && $driver->is_viable; + $self->{+IPC} = $driver->new or next; + $self->ipc_enable_shm if $self->{+IPC}->use_shm; + return; + } + + die "IPC has been requested, but no viable drivers were found. Aborting...\n"; +} + +sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 } + +sub add_formatter { + my $self = shift; + my ($formatter) = @_; + unshift @{$self->{+FORMATTERS}} => $formatter; + + return unless $self->{+FINALIZED}; + + # Why is the @CARP_NOT entry not enough? + local %Carp::Internal = %Carp::Internal; + $Carp::Internal{'Test2::Formatter'} = 1; + + carp "Formatter $formatter loaded too late to be used as the global formatter"; +} + +sub add_context_acquire_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-acquire callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code; +} + +sub add_context_init_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-init callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code; +} + +sub add_context_release_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-release callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code; +} + +sub add_post_load_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Post-load callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+POST_LOAD_CALLBACKS}} => $code; + $code->() if $self->{+LOADED}; +} + +sub load { + my $self = shift; + unless ($self->{+LOADED}) { + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + # This is for https://github.com/Test-More/test-more/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + # END blocks run in reverse order. This insures the END block is loaded + # as late as possible. It will not solve all cases, but it helps. + eval "END { Test2::API::test2_set_is_end() }; 1" or die $@; + + $self->{+LOADED} = 1; + $_->() for @{$self->{+POST_LOAD_CALLBACKS}}; + } + return $self->{+LOADED}; +} + +sub add_exit_callback { + my $self = shift; + my ($code) = @_; + my $rtype = reftype($code) || ""; + + confess "End callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+EXIT_CALLBACKS}} => $code; +} + +sub add_ipc_driver { + my $self = shift; + my ($driver) = @_; + unshift @{$self->{+IPC_DRIVERS}} => $driver; + + return unless $self->{+FINALIZED}; + + # Why is the @CARP_NOT entry not enough? + local %Carp::Internal = %Carp::Internal; + $Carp::Internal{'Test2::IPC::Driver'} = 1; + + carp "IPC driver $driver loaded too late to be used as the global ipc driver"; +} + +sub enable_ipc_polling { + my $self = shift; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + $self->add_context_init_callback( + # This is called every time a context is created, it needs to be fast. + # $_[0] is a context object + sub { + return unless $self->{+IPC_POLLING}; + return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID}; + + my $val; + { + shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return; + + return if $val eq $self->{+IPC_SHM_LAST}; + $self->{+IPC_SHM_LAST} = $val; + } + + $_[0]->{hub}->cull; + } + ) unless defined $self->ipc_polling; + + $self->set_ipc_polling(1); +} + +sub ipc_enable_shm { + my $self = shift; + + return 1 if defined $self->{+IPC_SHM_ID}; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + my ($ok, $err) = try { + # SysV IPC can be available but not enabled. + # + # In some systems (*BSD) accessing the SysV IPC APIs without + # them being enabled can cause a SIGSYS. We suppress the SIGSYS + # and then get ENOSYS from the calls. + local $SIG{SYS} = 'IGNORE'; + + require IPC::SysV; + + my $ipc_key = IPC::SysV::IPC_PRIVATE(); + my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64; + my $shm_id = shmget($ipc_key, $shm_size, 0666) or die; + + my $initial = 'a' x $shm_size; + shmwrite($shm_id, $initial, 0, $shm_size) or die; + + $self->{+IPC_SHM_SIZE} = $shm_size; + $self->{+IPC_SHM_ID} = $shm_id; + $self->{+IPC_SHM_LAST} = $initial; + }; + + return $ok; +} + +sub ipc_free_shm { + my $self = shift; + + my $id = delete $self->{+IPC_SHM_ID}; + return unless defined $id; + + shmctl($id, IPC::SysV::IPC_RMID(), 0); +} + +sub get_ipc_pending { + my $self = shift; + return -1 unless defined $self->{+IPC_SHM_ID}; + my $val; + shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1; + return 0 if $val eq $self->{+IPC_SHM_LAST}; + $self->{+IPC_SHM_LAST} = $val; + return 1; +} + +sub set_ipc_pending { + my $self = shift; + + return undef unless defined $self->{+IPC_SHM_ID}; + + my ($val) = @_; + + confess "value is required for set_ipc_pending" + unless $val; + + shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}); +} + +sub disable_ipc_polling { + my $self = shift; + return unless defined $self->{+IPC_POLLING}; + $self->{+IPC_POLLING} = 0; +} + +sub _ipc_wait { + my $fail = 0; + + if (CAN_FORK) { + while (1) { + my $pid = CORE::wait(); + my $err = $?; + last if $pid == -1; + next unless $err; + $fail++; + $err = $err >> 8; + warn "Process $pid did not exit cleanly (status: $err)\n"; + } + } + + if (USE_THREADS) { + for my $t (threads->list()) { + $t->join; + # In older threads we cannot check if a thread had an error unless + # we control it and its return. + my $err = $t->can('error') ? $t->error : undef; + next unless $err; + my $tid = $t->tid(); + $fail++; + chomp($err); + warn "Thread $tid did not end cleanly: $err\n"; + } + } + + return 0 unless $fail; + return 255; +} + +sub DESTROY { + my $self = shift; + + return unless defined($self->{+_PID}) && $self->{+_PID} == $$; + return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid(); + + shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0) + if defined $self->{+IPC_SHM_ID}; +} + +sub set_exit { + my $self = shift; + + my $exit = $?; + my $new_exit = $exit; + + if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) { + print STDERR <<" EOT"; + +******************************************************************************** +* * +* Test::Builder -- Test2::API version mismatch detected * +* * +******************************************************************************** + Test2::API Version: $Test2::API::VERSION +Test::Builder Version: $Test::Builder::VERSION + +This is not a supported configuration, you will have problems. + + EOT + } + + for my $ctx (values %{$self->{+CONTEXTS}}) { + next unless $ctx; + + next if $ctx->_aborted && ${$ctx->_aborted}; + + # Only worry about contexts in this PID + my $trace = $ctx->trace || next; + next unless $trace->pid && $trace->pid == $$; + + # Do not worry about contexts that have no hub + my $hub = $ctx->hub || next; + + # Do not worry if the state came to a sudden end. + next if $hub->bailed_out; + next if defined $hub->skip_reason; + + # now we worry + $trace->alert("context object was never released! This means a testing tool is behaving very badly"); + + $exit = 255; + $new_exit = 255; + } + + if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) { + $? = $exit; + return; + } + + my @hubs = $self->{+STACK} ? $self->{+STACK}->all : (); + + if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) { + local $?; + my %seen; + for my $hub (reverse @hubs) { + my $ipc = $hub->ipc or next; + next if $seen{$ipc}++; + $ipc->waiting(); + } + + my $ipc_exit = _ipc_wait(); + $new_exit ||= $ipc_exit; + } + + # None of this is necessary if we never got a root hub + if(my $root = shift @hubs) { + my $trace = Test2::Util::Trace->new( + frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], + detail => __PACKAGE__ . ' END Block finalization', + ); + my $ctx = Test2::API::Context->new( + trace => $trace, + hub => $root, + ); + + if (@hubs) { + $ctx->diag("Test ended with extra hubs on the stack!"); + $new_exit = 255; + } + + unless ($root->no_ending) { + local $?; + $root->finalize($trace) unless $root->ended; + $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}}; + $new_exit ||= $root->failed; + $new_exit ||= 255 unless $root->is_passing; + } + } + + $new_exit = 255 if $new_exit > 255; + + if ($new_exit && eval { require Test2::API::Breakage; 1 }) { + my @warn = Test2::API::Breakage->report(); + + if (@warn) { + print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n"; + print STDERR "$_\n" for @warn; + print STDERR "\n"; + } + } + + $? = $new_exit; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Instance - Object used by Test2::API under the hood + +=head1 DESCRIPTION + +This object encapsulates the global shared state tracked by +L. A single global instance of this package is stored (and +obscured) by the L package. + +There is no reason to directly use this package. This package is documented for +completeness. This package can change, or go away completely at any time. +Directly using, or monkeypatching this package is not supported in any way +shape or form. + +=head1 SYNOPSIS + + use Test2::API::Instance; + + my $obj = Test2::API::Instance->new; + +=over 4 + +=item $pid = $obj->pid + +PID of this instance. + +=item $obj->tid + +Thread ID of this instance. + +=item $obj->reset() + +Reset the object to defaults. + +=item $obj->load() + +Set the internal state to loaded, and run and stored post-load callbacks. + +=item $bool = $obj->loaded + +Check if the state is set to loaded. + +=item $arrayref = $obj->post_load_callbacks + +Get the post-load callbacks. + +=item $obj->add_post_load_callback(sub { ... }) + +Add a post-load callback. If C has already been called then the callback will +be immediately executed. If C has not been called then the callback will be +stored and executed later when C is called. + +=item $hashref = $obj->contexts() + +Get a hashref of all active contexts keyed by hub id. + +=item $arrayref = $obj->context_acquire_callbacks + +Get all context acquire callbacks. + +=item $arrayref = $obj->context_init_callbacks + +Get all context init callbacks. + +=item $arrayref = $obj->context_release_callbacks + +Get all context release callbacks. + +=item $obj->add_context_init_callback(sub { ... }) + +Add a context init callback. Subs are called every time a context is created. Subs +get the newly created context as their only argument. + +=item $obj->add_context_release_callback(sub { ... }) + +Add a context release callback. Subs are called every time a context is released. Subs +get the released context as their only argument. These callbacks should not +call release on the context. + +=item $obj->set_exit() + +This is intended to be called in an C block. This will look at +test state and set $?. This will also call any end callbacks, and wait on child +processes/threads. + +=item $obj->ipc_enable_shm() + +Turn on SHM for IPC (if possible) + +=item $shm_id = $obj->ipc_shm_id() + +If SHM is enabled for IPC this will be the shm_id for it. + +=item $shm_size = $obj->ipc_shm_size() + +If SHM is enabled for IPC this will be the size of it. + +=item $shm_last_val = $obj->ipc_shm_last() + +If SHM is enabled for IPC this will return the last SHM value seen. + +=item $obj->set_ipc_pending($val) + +use the IPC SHM to tell other processes and threads there is a pending event. +C<$val> should be a unique value no other thread/process will generate. + +B This will also make the current process see a pending event. It does +not set C, this is important because doing so could hide a +previous change. + +=item $pending = $obj->get_ipc_pending() + +This returns -1 if SHM is not enabled for IPC. + +This returns 0 if the SHM value matches the last known value, which means there +are no pending events. + +This returns 1 if the SHM value has changed, which means there are probably +pending events. + +When 1 is returned this will set C<< $obj->ipc_shm_last() >>. + +=item $drivers = $obj->ipc_drivers + +Get the list of IPC drivers. + +=item $obj->add_ipc_driver($DRIVER_CLASS) + +Add an IPC driver to the list. The most recently added IPC driver will become +the global one during initialization. If a driver is added after initialization +has occurred a warning will be generated: + + "IPC driver $driver loaded too late to be used as the global ipc driver" + +=item $bool = $obj->ipc_polling + +Check if polling is enabled. + +=item $obj->enable_ipc_polling + +Turn on polling. This will cull events from other processes and threads every +time a context is created. + +=item $obj->disable_ipc_polling + +Turn off IPC polling. + +=item $bool = $obj->no_wait + +=item $bool = $obj->set_no_wait($bool) + +Get/Set no_wait. This option is used to turn off process/thread waiting at exit. + +=item $arrayref = $obj->exit_callbacks + +Get the exit callbacks. + +=item $obj->add_exit_callback(sub { ... }) + +Add an exit callback. This callback will be called by C. + +=item $bool = $obj->finalized + +Check if the object is finalized. Finalization happens when either C, +C, or C are called on the object. Once finalization happens +these fields are considered unchangeable (not enforced here, enforced by +L). + +=item $ipc = $obj->ipc + +Get the one true IPC instance. + +=item $stack = $obj->stack + +Get the one true hub stack. + +=item $formatter = $obj->formatter + +Get the global formatter. By default this is the C<'Test2::Formatter::TAP'> +package. This could be any package that implements the C method. This +can also be an instantiated object. + +=item $bool = $obj->formatter_set() + +Check if a formatter has been set. + +=item $obj->add_formatter($class) + +=item $obj->add_formatter($obj) + +Add a formatter. The most recently added formatter will become the global one +during initialization. If a formatter is added after initialization has occurred +a warning will be generated: + + "Formatter $formatter loaded too late to be used as the global formatter" + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/API/Stack.pm b/dist/Test-Simple/lib/Test2/API/Stack.pm new file mode 100644 index 00000000000..35b6d68f1ee --- /dev/null +++ b/dist/Test-Simple/lib/Test2/API/Stack.pm @@ -0,0 +1,220 @@ +package Test2::API::Stack; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Test2::Hub(); + +use Carp qw/confess/; + +sub new { + my $class = shift; + return bless [], $class; +} + +sub new_hub { + my $self = shift; + my %params = @_; + + my $class = delete $params{class} || 'Test2::Hub'; + + my $hub = $class->new(%params); + + if (@$self) { + $hub->inherit($self->[-1], %params); + } + else { + require Test2::API; + $hub->format(Test2::API::test2_formatter()->new) + unless $hub->format || exists($params{formatter}); + + my $ipc = Test2::API::test2_ipc(); + if ($ipc && !$hub->ipc && !exists($params{ipc})) { + $hub->set_ipc($ipc); + $ipc->add_hub($hub->hid); + } + } + + push @$self => $hub; + + $hub; +} + +sub top { + my $self = shift; + return $self->new_hub unless @$self; + return $self->[-1]; +} + +sub peek { + my $self = shift; + return @$self ? $self->[-1] : undef; +} + +sub cull { + my $self = shift; + $_->cull for reverse @$self; +} + +sub all { + my $self = shift; + return @$self; +} + +sub clear { + my $self = shift; + @$self = (); +} + +# Do these last without keywords in order to prevent them from getting used +# when we want the real push/pop. + +{ + no warnings 'once'; + + *push = sub { + my $self = shift; + my ($hub) = @_; + $hub->inherit($self->[-1]) if @$self; + push @$self => $hub; + }; + + *pop = sub { + my $self = shift; + my ($hub) = @_; + confess "No hubs on the stack" + unless @$self; + confess "You cannot pop the root hub" + if 1 == @$self; + confess "Hub stack mismatch, attempted to pop incorrect hub" + unless $self->[-1] == $hub; + pop @$self; + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Stack - Object to manage a stack of L +instances. + +=head1 ***INTERNALS NOTE*** + +B The public +methods provided will not change in backwards incompatible ways, but the +underlying implementation details might. B + +=head1 DESCRIPTION + +This module is used to represent and manage a stack of L +objects. Hubs are usually in a stack so that you can push a new hub into place +that can intercept and handle events differently than the primary hub. + +=head1 SYNOPSIS + + my $stack = Test2::API::Stack->new; + my $hub = $stack->top; + +=head1 METHODS + +=over 4 + +=item $stack = Test2::API::Stack->new() + +This will create a new empty stack instance. All arguments are ignored. + +=item $hub = $stack->new_hub() + +=item $hub = $stack->new_hub(%params) + +=item $hub = $stack->new_hub(%params, class => $class) + +This will generate a new hub and push it to the top of the stack. Optionally +you can provide arguments that will be passed into the constructor for the +L object. + +If you specify the C<< 'class' => $class >> argument, the new hub will be an +instance of the specified class. + +Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the +formatter and IPC instance will be inherited from the current top hub. You can +set the parameters to C to avoid having a formatter or IPC instance. + +If there is no top hub, and you do not ask to leave IPC and formatter undef, +then a new formatter will be created, and the IPC instance from +L will be used. + +=item $hub = $stack->top() + +This will return the top hub from the stack. If there is no top hub yet this +will create it. + +=item $hub = $stack->peek() + +This will return the top hub from the stack. If there is no top hub yet this +will return undef. + +=item $stack->cull + +This will call C<< $hub->cull >> on all hubs in the stack. + +=item @hubs = $stack->all + +This will return all the hubs in the stack as a list. + +=item $stack->clear + +This will completely remove all hubs from the stack. Normally you do not want +to do this, but there are a few valid reasons for it. + +=item $stack->push($hub) + +This will push the new hub onto the stack. + +=item $stack->pop($hub) + +This will pop a hub from the stack, if the hub at the top of the stack does not +match the hub you expect (passed in as an argument) it will throw an exception. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event.pm b/dist/Test-Simple/lib/Test2/Event.pm new file mode 100644 index 00000000000..ec545a9c57e --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event.pm @@ -0,0 +1,287 @@ +package Test2::Event; +use strict; +use warnings; + +our $VERSION = '1.302075'; + +use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/; +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util qw(pkg_to_file); +use Test2::Util::Trace; + +sub causes_fail { 0 } +sub increments_count { 0 } +sub diagnostics { 0 } +sub no_display { 0 } + +sub callback { } + +sub terminate { () } +sub global { () } +sub sets_plan { () } + +sub summary { ref($_[0]) } + +sub related { + my $self = shift; + my ($event) = @_; + + my $tracea = $self->trace or return undef; + my $traceb = $event->trace or return undef; + + my $siga = $tracea->signature or return undef; + my $sigb = $traceb->signature or return undef; + + return 1 if $siga eq $sigb; + return 0; +} + +sub from_json { + my $class = shift; + my %p = @_; + + my $event_pkg = delete $p{__PACKAGE__}; + require(pkg_to_file($event_pkg)); + + if (exists $p{trace}) { + $p{trace} = Test2::Util::Trace->from_json(%{$p{trace}}); + } + + if (exists $p{subevents}) { + my @subevents; + for my $subevent (@{delete $p{subevents} || []}) { + push @subevents, Test2::Event->from_json(%$subevent); + } + $p{subevents} = \@subevents; + } + + return $event_pkg->new(%p); +} + +sub TO_JSON { + my $self = shift; + return {%$self, __PACKAGE__ => ref $self}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event - Base class for events + +=head1 DESCRIPTION + +Base class for all event objects that get passed through +L. + +=head1 SYNOPSIS + + package Test2::Event::MyEvent; + use strict; + use warnings; + + # This will make our class an event subclass (required) + use base 'Test2::Event'; + + # Add some accessors (optional) + # You are not obligated to use HashBase, you can use any object tool you + # want, or roll your own accessors. + use Test2::Util::HashBase qw/foo bar baz/; + + # Chance to initialize some defaults + sub init { + my $self = shift; + # no other args in @_ + + $self->set_foo('xxx') unless defined $self->foo; + + ... + } + + 1; + +=head1 METHODS + +=over 4 + +=item $trace = $e->trace + +Get a snapshot of the L as it was when this event was +generated + +=item $bool = $e->causes_fail + +Returns true if this event should result in a test failure. In general this +should be false. + +=item $bool = $e->increments_count + +Should be true if this event should result in a test count increment. + +=item $e->callback($hub) + +If your event needs to have extra effects on the L you can override +this method. + +This is called B your event is passed to the formatter. + +=item $call = $e->created + +Get the C details from when the event was generated. This is usually +inside a tools package. This is typically used for debugging. + +=item $num = $e->nested + +If this event is nested inside of other events, this should be the depth of +nesting. (This is mainly for subtests) + +=item $bool = $e->global + +Set this to true if your event is global, that is ALL threads and processes +should see it no matter when or where it is generated. This is not a common +thing to want, it is used by bail-out and skip_all to end testing. + +=item $code = $e->terminate + +This is called B your event has been passed to the formatter. This +should normally return undef, only change this if your event should cause the +test to exit immediately. + +If you want this event to cause the test to exit you should return the exit +code here. Exit code of 0 means exit success, any other integer means exit with +failure. + +This is used by L to exit 0 when the plan is +'skip_all'. This is also used by L to force the test +to exit with a failure. + +This is called after the event has been sent to the formatter in order to +ensure the event is seen and understood. + +=item $todo = $e->todo + +=item $e->set_todo($todo) + +Get/Set the todo reason on the event. Any value other than C makes the +event 'TODO'. + +Not all events make use of this field, but they can all have it set/cleared. + +=item $bool = $e->diag_todo + +=item $e->diag_todo($todo) + +True if this event should be considered 'TODO' for diagnostics purposes. This +essentially means that any message that would go to STDERR will go to STDOUT +instead so that a harness will hide it outside of verbose mode. + +=item $msg = $e->summary + +This is intended to be a human readable summary of the event. This should +ideally only be one line long, but you can use multiple lines if necessary. This +is intended for human consumption. You do not need to make it easy for machines +to understand. + +The default is to simply return the event package name. + +=item ($count, $directive, $reason) = $e->sets_plan() + +Check if this event sets the testing plan. It will return an empty list if it +does not. If it does set the plan it will return a list of 1 to 3 items in +order: Expected Test Count, Test Directive, Reason for directive. + +=item $bool = $e->diagnostics + +True if the event contains diagnostics info. This is useful because a +non-verbose harness may choose to hide events that are not in this category. +Some formatters may choose to send these to STDERR instead of STDOUT to ensure +they are seen. + +=item $bool = $e->no_display + +False by default. This will return true on events that should not be displayed +by formatters. + +=item $id = $e->in_subtest + +If the event is inside a subtest this should have the subtest ID. + +=item $id = $e->subtest_id + +If the event is a final subtest event, this should contain the subtest ID. + +=item $bool_or_undef = $e->related($e2) + +Check if 2 events are related. In this case related means their traces share a +signature meaning they were created with the same context (or at the very least +by contexts which share an id, which is the same thing unless someone is doing +something very bad). + +This can be used to reliably link multiple events created by the same tool. For +instance a failing test like C will generate 2 events, one being +a L, the other being a L, both of these +events are related having been created under the same context and by the same +initial tool (though multiple tools may have been nested under the initial +one). + +This will return C if the relationship cannot be checked, which happens +if either event has an incomplete or missing trace. This will return C<0> if +the traces are complete, but do not match. C<1> will be returned if there is a +match. + +=item $hashref = $e->TO_JSON + +This returns a hashref suitable for passing to the C<< Test2::Event->from_json +>> constructor. It is intended for use with the L family of modules, +which will look for a C method when C is true. + +=item $e = Test2::Event->from_json(%$hashref) + +Given the hash of data returned by C<< $e->TO_JSON >>, this method returns a +new event object of the appropriate subclass. + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Bail.pm b/dist/Test-Simple/lib/Test2/Event/Bail.pm new file mode 100644 index 00000000000..0842a8b0c96 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Bail.pm @@ -0,0 +1,102 @@ +package Test2::Event::Bail; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{reason}; + +sub callback { + my $self = shift; + my ($hub) = @_; + + $hub->set_bailed_out($self); +} + +# Make sure the tests terminate +sub terminate { 255 }; + +sub global { 1 }; + +sub causes_fail { 1 } + +sub summary { + my $self = shift; + return "Bail out! " . $self->{+REASON} + if $self->{+REASON}; + + return "Bail out!"; +} + +sub diagnostics { 1 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::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 SYNOPSIS + + use Test2::API qw/context/; + use Test2::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. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Diag.pm b/dist/Test-Simple/lib/Test2/Event/Diag.pm new file mode 100644 index 00000000000..f8116633f6a --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Diag.pm @@ -0,0 +1,83 @@ +package Test2::Event::Diag; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/message/; + +sub init { + $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; +} + +sub summary { $_[0]->{+MESSAGE} } + +sub diagnostics { 1 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Diag - Diag event type + +=head1 DESCRIPTION + +Diagnostics messages, typically rendered to STDERR. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Diag; + + my $ctx = context(); + my $event = $ctx->diag($message); + +=head1 ACCESSORS + +=over 4 + +=item $diag->message + +The message for the diag. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Encoding.pm b/dist/Test-Simple/lib/Test2/Event/Encoding.pm new file mode 100644 index 00000000000..e8690feb7fa --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Encoding.pm @@ -0,0 +1,86 @@ +package Test2::Event::Encoding; +use strict; +use warnings; + +our $VERSION = '1.302075'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/encoding/; + +sub init { + my $self = shift; + defined $self->{+ENCODING} or $self->trace->throw("'encoding' is a required attribute"); +} + +sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Encoding - Set the encoding for the output stream + +=head1 DESCRIPTION + +The encoding event is generated when a test file wants to specify the encoding +to be used when formatting its output. This event is intended to be produced +by formatter classes and used for interpreting test names, message contents, +etc. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Encoding; + + my $ctx = context(); + my $event = $ctx->send_event('Encoding', encoding => 'UTF-8'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $encoding = $e->encoding + +The encoding being specified. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Exception.pm b/dist/Test-Simple/lib/Test2/Event/Exception.pm new file mode 100644 index 00000000000..0eb00778ada --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Exception.pm @@ -0,0 +1,88 @@ +package Test2::Event::Exception; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{error}; + +sub causes_fail { 1 } + +sub summary { + my $self = shift; + chomp(my $msg = "Exception: " . $self->{+ERROR}); + return $msg; +} + +sub diagnostics { 1 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Exception - Exception event + +=head1 DESCRIPTION + +An exception event will display to STDERR, and will prevent the overall test +file from passing. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Exception; + + my $ctx = context(); + my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $reason = $e->error + +The reason for the exception. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Generic.pm b/dist/Test-Simple/lib/Test2/Event/Generic.pm new file mode 100644 index 00000000000..ecf8f054464 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Generic.pm @@ -0,0 +1,263 @@ +package Test2::Event::Generic; +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +our $VERSION = '1.302075'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase; + +my @FIELDS = qw{ + causes_fail increments_count diagnostics no_display callback terminate + global sets_plan summary +}; +my %DEFAULTS = ( + causes_fail => 0, + increments_count => 0, + diagnostics => 0, + no_display => 0, +); + +sub init { + my $self = shift; + + for my $field (@FIELDS) { + my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field}; + next unless defined $val; + + my $set = "set_$field"; + $self->$set($val); + } +} + +for my $field (@FIELDS) { + no strict 'refs'; + my $stash = \%{__PACKAGE__ . "::"}; + + *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } + unless defined $stash->{$field} + && defined *{$stash->{$field}}{CODE}; + + *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } + unless defined $stash->{"set_$field"} + && defined *{$stash->{"set_$field"}}{CODE}; +} + +sub summary { + my $self = shift; + return $self->{summary} if defined $self->{summary}; + $self->SUPER::summary(); +} + +sub sets_plan { + my $self = shift; + return unless $self->{sets_plan}; + return @{$self->{sets_plan}}; +} + +sub callback { + my $self = shift; + my $cb = $self->{callback} || return; + $self->$cb(@_); +} + +sub set_global { + my $self = shift; + my ($bool) = @_; + + if(!defined $bool) { + delete $self->{global}; + return undef; + } + + $self->{global} = $bool; +} + +sub set_callback { + my $self = shift; + my ($cb) = @_; + + if(!defined $cb) { + delete $self->{callback}; + return undef; + } + + croak "callback must be a code reference" + unless ref($cb) && reftype($cb) eq 'CODE'; + + $self->{callback} = $cb; +} + +sub set_terminate { + my $self = shift; + my ($exit) = @_; + + if(!defined $exit) { + delete $self->{terminate}; + return undef; + } + + croak "terminate must be a positive integer" + unless $exit =~ m/^\d+$/; + + $self->{terminate} = $exit; +} + +sub set_sets_plan { + my $self = shift; + my ($plan) = @_; + + if(!defined $plan) { + delete $self->{sets_plan}; + return undef; + } + + croak "'sets_plan' must be an array reference" + unless ref($plan) && reftype($plan) eq 'ARRAY'; + + $self->{sets_plan} = $plan; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Generic - Generic event type. + +=head1 DESCRIPTION + +This is a generic event that lets you customize all fields in the event API. +This is useful if you have need for a custom event that does not make sense as +a published reusable event subclass. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub send_custom_fail { + my $ctx = shift; + + $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling'); + + $ctx->release; + } + + send_custom_fail(); + +=head1 METHODS + +=over 4 + +=item $e->callback($hub) + +Call the custom callback if one is set, otherwise this does nothing. + +=item $e->set_callback(sub { ... }) + +Set the custom callback. The custom callback must be a coderef. The first +argument to your callback will be the event itself, the second will be the +L that is using the callback. + +=item $bool = $e->causes_fail + +=item $e->set_causes_fail($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool = $e->diagnostics + +=item $e->set_diagnostics($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool_or_undef = $e->global + +=item @bool_or_empty = $e->global + +=item $e->set_global($bool_or_undef) + +Get/Set the C attribute. This defaults to an empty list which is +undef in scalar context. + +=item $bool = $e->increments_count + +=item $e->set_increments_count($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool = $e->no_display + +=item $e->set_no_display($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item @plan = $e->sets_plan + +Get the plan if this event sets one. The plan is a list of up to 3 items: +C<($count, $directive, $reason)>. C<$count> must be defined, the others may be +undef, or may not exist at all. + +=item $e->set_sets_plan(\@plan) + +Set the plan. You must pass in an arrayref with up to 3 elements. + +=item $summary = $e->summary + +=item $e->set_summary($summary_or_undef) + +Get/Set the summary. This will default to the event package +C<'Test2::Event::Generic'>. You can set it to any value. Setting this to +C will reset it to the default. + +=item $int_or_undef = $e->terminate + +=item @int_or_empty = $e->terminate + +=item $e->set_terminate($int_or_undef) + +This will get/set the C attribute. This defaults to undef in scalar +context, or an empty list in list context. Setting this to undef will clear it +completely. This must be set to a positive integer (0 or larger). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Info.pm b/dist/Test-Simple/lib/Test2/Event/Info.pm new file mode 100644 index 00000000000..259dbfc45cc --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Info.pm @@ -0,0 +1,127 @@ +package Test2::Event::Info; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; + +our $VERSION = '1.302075'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/diagnostics renderer/; + +sub init { + my $self = shift; + + my $r = $self->{+RENDERER} or $self->trace->throw("'renderer' is a required attribute"); + + return if ref($r) eq 'CODE'; + return if blessed($r) && $r->can('render'); + + $self->trace->throw("renderer '$r' is not a valid renderer, must be a coderef or an object implementing the 'render()' method"); +} + +sub render { + my $self = shift; + my ($fmt) = @_; + + $fmt ||= 'text'; + + my $r = $self->{+RENDERER}; + + return $r->($fmt) if ref($r) eq 'CODE'; + return $r->render($fmt); +} + +sub summary { $_[0]->render($_[1] || 'text') } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Info - Info event base class + +=head1 DESCRIPTION + +Successor for note and diag events. This event base class supports multiple +formats. This event makes it possible to send additional information such as +color and highlighting to the harness. + +=head1 SYNOPSIS + + use Test2::API::Context qw/context/; + + $ctx->info($obj, diagnostics => $bool); + +=head1 FORMATS + +Format will be passed in to C and C as a string. Any +string is considered valid, if your event does not recognize the format it +should fallback to 'text'. + +=over 4 + +=item 'text' + +Plain and ordinary text. + +=item 'ansi' + +Text that may include ansi sequences such as colors. + +=item 'html' + +HTML formatted text. + +=back + +=head1 ACCESSORS + +=over 4 + +=item $bool = $info->diagnostics() + +=item $info->set_diagnostics($bool) + +True if this info is essential for diagnostics. The implication is that +diagnostics will got to STDERR while everything else goes to STDOUT, but that +is formatter/harness specific. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Note.pm b/dist/Test-Simple/lib/Test2/Event/Note.pm new file mode 100644 index 00000000000..3f4089d483b --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Note.pm @@ -0,0 +1,81 @@ +package Test2::Event::Note; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/message/; + +sub init { + $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; +} + +sub summary { $_[0]->{+MESSAGE} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Note - Note event type + +=head1 DESCRIPTION + +Notes, typically rendered to STDOUT. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Note; + + my $ctx = context(); + my $event = $ctx->Note($message); + +=head1 ACCESSORS + +=over 4 + +=item $note->message + +The message for the note. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Ok.pm b/dist/Test-Simple/lib/Test2/Event/Ok.pm new file mode 100644 index 00000000000..96d9fa84f1c --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Ok.pm @@ -0,0 +1,140 @@ +package Test2::Event::Ok; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{ + pass effective_pass name todo +}; + +sub init { + my $self = shift; + + # Do not store objects here, only true or false + $self->{+PASS} = $self->{+PASS} ? 1 : 0; + $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0); +} + +{ + no warnings 'redefine'; + sub set_todo { + my $self = shift; + my ($todo) = @_; + $self->{+TODO} = $todo; + $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS}; + } +} + +sub increments_count { 1 }; + +sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} } + +sub summary { + my $self = shift; + + my $name = $self->{+NAME} || "Nameless Assertion"; + + my $todo = $self->{+TODO}; + if ($todo) { + $name .= " (TODO: $todo)"; + } + elsif (defined $todo) { + $name .= " (TODO)" + } + + return $name; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::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 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Ok; + + my $ctx = context(); + my $event = $ctx->ok($bool, $name, \@diag); + +or: + + my $ctx = context(); + my $event = $ctx->send_event( + 'Ok', + pass => $bool, + name => $name, + ); + +=head1 ACCESSORS + +=over 4 + +=item $rb = $e->pass + +The original true/false value of whatever was passed into the event (but +reduced down to 1 or 0). + +=item $name = $e->name + +Name of the test. + +=item $b = $e->effective_pass + +This is the true/false value of the test after TODO and similar modifiers are +taken into account. + +=item $b = $e->allow_bad_name + +This relaxes the test name checks such that they allow characters that can +confuse a TAP parser. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Plan.pm b/dist/Test-Simple/lib/Test2/Event/Plan.pm new file mode 100644 index 00000000000..4f2a435c49c --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Plan.pm @@ -0,0 +1,160 @@ +package Test2::Event::Plan; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{max directive reason}; + +use Carp qw/confess/; + +my %ALLOWED = ( + 'SKIP' => 1, + 'NO PLAN' => 1, +); + +sub 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 { + confess "Cannot have a reason without a directive!" + if defined $_[0]->{+REASON}; + + confess "No number of tests specified" + unless defined $_[0]->{+MAX}; + + confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer" + unless $_[0]->{+MAX} =~ m/^\d+$/; + + $_[0]->{+DIRECTIVE} = ''; + } +} + +sub sets_plan { + my $self = shift; + return ( + $self->{+MAX}, + $self->{+DIRECTIVE}, + $self->{+REASON}, + ); +} + +sub callback { + my $self = shift; + my ($hub) = @_; + + $hub->plan($self->{+DIRECTIVE} || $self->{+MAX}); + + return unless $self->{+DIRECTIVE}; + + $hub->set_skip_reason($self->{+REASON} || 1) if $self->{+DIRECTIVE} eq 'SKIP'; +} + +sub terminate { + my $self = shift; + # On skip_all we want to terminate the hub + return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; + return undef; +} + +sub summary { + my $self = shift; + my $max = $self->{+MAX}; + my $directive = $self->{+DIRECTIVE}; + my $reason = $self->{+REASON}; + + return "Plan is $max assertions" + if $max || !$directive; + + return "Plan is '$directive', $reason" + if $reason; + + return "Plan is '$directive'"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::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 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Plan; + + my $ctx = context(); + + # Plan for 10 tests to run + my $event = $ctx->plan(10); + + # Plan to skip all tests (will exit 0) + $ctx->plan(0, skip_all => "These tests need to be skipped"); + +=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 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Skip.pm b/dist/Test-Simple/lib/Test2/Event/Skip.pm new file mode 100644 index 00000000000..22c51062980 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Skip.pm @@ -0,0 +1,108 @@ +package Test2::Event::Skip; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } +use Test2::Util::HashBase qw{reason}; + +sub init { + my $self = shift; + $self->SUPER::init; + $self->{+EFFECTIVE_PASS} = 1; +} + +sub causes_fail { 0 } + +sub summary { + my $self = shift; + my $out = $self->SUPER::summary(@_); + + if (my $reason = $self->reason) { + $out .= " (SKIP: $reason)"; + } + else { + $out .= " (SKIP)"; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Skip - Skip event type + +=head1 DESCRIPTION + +Skip events bump test counts just like L events, but +they can never fail. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Skip; + + my $ctx = context(); + my $event = $ctx->skip($name, $reason); + +or: + + my $ctx = context(); + my $event = $ctx->send_event( + 'Skip', + name => $name, + reason => $reason, + ); + +=head1 ACCESSORS + +=over 4 + +=item $reason = $e->reason + +The original true/false value of whatever was passed into the event (but +reduced down to 1 or 0). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Subtest.pm b/dist/Test-Simple/lib/Test2/Event/Subtest.pm new file mode 100644 index 00000000000..0d59aedf037 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Subtest.pm @@ -0,0 +1,131 @@ +package Test2::Event::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } +use Test2::Util::HashBase qw{subevents buffered subtest_id}; + +sub init { + my $self = shift; + $self->SUPER::init(); + $self->{+SUBEVENTS} ||= []; + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } +} + +{ + no warnings 'redefine'; + + sub set_subevents { + my $self = shift; + my @subevents = @_; + + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; + } + + $self->{+SUBEVENTS} = \@subevents; + } + + sub set_effective_pass { + my $self = shift; + my ($pass) = @_; + + if ($pass) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } + elsif ($self->{+EFFECTIVE_PASS} && !$pass) { + for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { + $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; + } + } + + $self->{+EFFECTIVE_PASS} = $pass; + } +} + +sub summary { + my $self = shift; + + my $name = $self->{+NAME} || "Nameless Subtest"; + + my $todo = $self->{+TODO}; + if ($todo) { + $name .= " (TODO: $todo)"; + } + elsif (defined $todo) { + $name .= " (TODO)" + } + + return $name; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Subtest - Event for subtest types + +=head1 DESCRIPTION + +This class represents a subtest. This class is a subclass of +L. + +=head1 ACCESSORS + +This class inherits from L. + +=over 4 + +=item $arrayref = $e->subevents + +Returns the arrayref containing all the events from the subtest + +=item $bool = $e->buffered + +True if the subtest is buffered, that is all subevents render at once. If this +is false it means all subevents render as they are produced. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/TAP/Version.pm b/dist/Test-Simple/lib/Test2/Event/TAP/Version.pm new file mode 100644 index 00000000000..fd5e4373acc --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/TAP/Version.pm @@ -0,0 +1,83 @@ +package Test2::Event::TAP::Version; +use strict; +use warnings; + +our $VERSION = '1.302075'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/version/; + +sub init { + my $self = shift; + defined $self->{+VERSION} or $self->trace->throw("'version' is a required attribute"); +} + +sub summary { 'TAP version ' . $_[0]->{+VERSION} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::TAP::Version - Event for TAP version. + +=head1 DESCRIPTION + +This event is used if a TAP formatter wishes to set a version. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Encoding; + + my $ctx = context(); + my $event = $ctx->send_event('TAP::Version', version => 42); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $version = $e->version + +The TAP version being parsed. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Event/Waiting.pm b/dist/Test-Simple/lib/Test2/Event/Waiting.pm new file mode 100644 index 00000000000..89fd0836a3a --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Event/Waiting.pm @@ -0,0 +1,61 @@ +package Test2::Event::Waiting; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } + +sub global { 1 }; + +sub summary { "IPC is waiting for children to finish..." } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Waiting - Tell all procs/threads it is time to be done + +=head1 DESCRIPTION + +This event has no data of its own. This event is sent out by the IPC system +when the main process/thread is ready to end. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Formatter.pm b/dist/Test-Simple/lib/Test2/Formatter.pm new file mode 100644 index 00000000000..c55d7df60b1 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Formatter.pm @@ -0,0 +1,128 @@ +package Test2::Formatter; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +my %ADDED; +sub import { + my $class = shift; + return if $class eq __PACKAGE__; + return if $ADDED{$class}++; + require Test2::API; + Test2::API::test2_formatter_add($class); +} + +sub hide_buffered { 1 } + +sub terminate { } + +sub finalize { } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter - Namespace for formatters. + +=head1 DESCRIPTION + +This is the namespace for formatters. This is an empty package. + +=head1 CREATING FORMATTERS + +A formatter is any package or object with a C method. + + package Test2::Formatter::Foo; + use strict; + use warnings; + + sub write { + my $self_or_class = shift; + my ($event, $assert_num) = @_; + ... + } + + sub hide_buffered { 1 } + + sub terminate { } + + sub finalize { } + + 1; + +The C method is a method, so it either gets a class or instance. The two +arguments are the C<$event> object it should record, and the C<$assert_num> +which is the number of the current assertion (ok), or the last assertion if +this even is not itself an assertion. The assertion number may be any integer 0 +or greater, and may be undefined in some cases. + +The C method must return a boolean. This is used to tell +buffered subtests whether or not to send it events as they are being buffered. +See L for more information. + +The C and C methods are optional methods called that you +can implement if the format you're generating needs to handle these cases, for +example if you are generating XML and need close open tags. + +The C method is called when an event's C method returns +true, for example when a L has a C<'skip_all'> plan, or +when a L event is sent. The C method is passed +a single argument, the L object which triggered the terminate. + +The C method is always the last thing called on the formatter, I<< +except when C is called for a Bail event >>. It is passed the +following arguments: + +=over 4 + +=item * The number of tests that were planned + +=item * The number of tests actually seen + +=item * The number of tests which failed + +=item * A boolean indicating whether or not the test suite passed + +=item * A boolean indicating whether or not this call is for a subtest + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Formatter/TAP.pm b/dist/Test-Simple/lib/Test2/Formatter/TAP.pm new file mode 100644 index 00000000000..00de718f1a8 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Formatter/TAP.pm @@ -0,0 +1,538 @@ +package Test2::Formatter::TAP; +use strict; +use warnings; +require PerlIO; + +our $VERSION = '1.302075'; + +use Test2::Util::HashBase qw{ + no_numbers handles _encoding +}; + +sub OUT_STD() { 0 } +sub OUT_ERR() { 1 } + +use Carp qw/croak/; + +BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } + +my %CONVERTERS = ( + 'Test2::Event::Ok' => 'event_ok', + 'Test2::Event::Skip' => 'event_skip', + 'Test2::Event::Note' => 'event_note', + 'Test2::Event::Diag' => 'event_diag', + 'Test2::Event::Bail' => 'event_bail', + 'Test2::Event::Exception' => 'event_exception', + 'Test2::Event::Subtest' => 'event_subtest', + 'Test2::Event::Plan' => 'event_plan', + 'Test2::Event::TAP::Version' => 'event_version', +); + +# Initial list of converters are safe for direct hash access cause we control them. +my %SAFE_TO_ACCESS_HASH = %CONVERTERS; + +sub register_event { + my $class = shift; + my ($type, $convert) = @_; + croak "Event type is a required argument" unless $type; + croak "Event type '$type' already registered" if $CONVERTERS{$type}; + croak "The second argument to register_event() must be a code reference or method name" + unless $convert && (ref($convert) eq 'CODE' || $class->can($convert)); + $CONVERTERS{$type} = $convert; +} + +_autoflush(\*STDOUT); +_autoflush(\*STDERR); + +sub init { + my $self = shift; + + $self->{+HANDLES} ||= $self->_open_handles; + if(my $enc = delete $self->{encoding}) { + $self->encoding($enc); + } +} + +sub hide_buffered { 1 } + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + my $handles = $self->{+HANDLES}; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + if ($enc =~ m/^utf-?8$/i) { + binmode($_, ":utf8") for @$handles; + } + else { + binmode($_, ":encoding($enc)") for @$handles; + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num) = @_; + + my $type = ref($e); + + my $converter = $CONVERTERS{$type} || 'event_other'; + my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return; + + my $handles = $self->{+HANDLES}; + my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0; + my $indent = ' ' x $nesting; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + for my $set (@tap) { + no warnings 'uninitialized'; + my ($hid, $msg) = @$set; + next unless $msg; + my $io = $handles->[$hid] or next; + + $msg =~ s/^/$indent/mg if $nesting; + print $io $msg; + } +} + +sub _open_handles { + my $self = shift; + + my %seen; + open(my $out, '>&', STDOUT) or die "Can't dup STDOUT: $!"; + binmode($out, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDOUT))); + + %seen = (); + open(my $err, '>&', STDERR) or die "Can't dup STDERR: $!"; + binmode($err, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDERR))); + + _autoflush($out); + _autoflush($err); + + return [$out, $err]; +} + +sub _autoflush { + my($fh) = pop; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + +sub event_tap { + my $self = shift; + my ($e, $num) = @_; + + my $converter = $CONVERTERS{ref($e)} or return; + + $num = undef if $self->{+NO_NUMBERS}; + + return $self->$converter($e, $num); +} + +sub event_ok { + my $self = shift; + my ($e, $num) = @_; + + # We use direct hash access for performance. OK events are so common we + # need this to be fast. + my ($name, $todo) = @{$e}{qw/name todo/}; + my $in_todo = defined($todo); + + my $out = ""; + $out .= "not " unless $e->{pass}; + $out .= "ok"; + $out .= " $num" if defined($num); + + # The regex form is ~250ms, the index form is ~50ms + my @extra; + defined($name) && ( + (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))), + ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g))) + ); + + my $space = @extra ? ' ' x (length($out) + 2) : ''; + + $out .= " - $name" if defined $name; + $out .= " # TODO" if $in_todo; + $out .= " $todo" if defined($todo) && length($todo); + + # The primary line of TAP, if the test passed this is all we need. + return([OUT_STD, "$out\n"]) unless @extra; + + return $self->event_ok_multiline($out, $space, @extra); +} + +sub event_ok_multiline { + my $self = shift; + my ($out, $space, @extra) = @_; + + return( + [OUT_STD, "$out\n"], + map {[OUT_STD, "#${space}$_\n"]} @extra, + ); +} + +sub event_skip { + my $self = shift; + my ($e, $num) = @_; + + my $name = $e->name; + my $reason = $e->reason; + my $todo = $e->todo; + + my $out = ""; + $out .= "not " unless $e->{pass}; + $out .= "ok"; + $out .= " $num" if defined $num; + $out .= " - $name" if $name; + if (defined($todo)) { + $out .= " # TODO & SKIP" + } + else { + $out .= " # skip"; + } + $out .= " $reason" if defined($reason) && length($reason); + + return([OUT_STD, "$out\n"]); +} + +sub event_note { + my $self = shift; + my ($e, $num) = @_; + + chomp(my $msg = $e->message); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + + return [OUT_STD, "$msg\n"]; +} + +sub event_diag { + my $self = shift; + my ($e, $num) = @_; + + chomp(my $msg = $e->message); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + + return [OUT_ERR, "$msg\n"]; +} + +sub event_bail { + my $self = shift; + my ($e, $num) = @_; + + return if $e->nested; + + return [ + OUT_STD, + "Bail out! " . $e->reason . "\n", + ]; +} + +sub event_exception { + my $self = shift; + my ($e, $num) = @_; + return [ OUT_ERR, $e->error ]; +} + +sub event_subtest { + my $self = shift; + my ($e, $num) = @_; + + # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render + # this event. + my ($ok, @diag) = $self->event_ok($e, $num); + + # If the subtest is not buffered then the sub-events have already been + # rendered, we can go ahead and return. + return ($ok, @diag) unless $e->buffered; + + # In a verbose harness we indent the diagnostics from the 'Ok' event since + # they will appear inside the subtest braces. This helps readability. In a + # non-verbose harness we do not do this because it is less readable. + if ($ENV{HARNESS_IS_VERBOSE}) { + # index 0 is the filehandle, index 1 is the message we want to indent. + $_->[1] =~ s/^(.*\S.*)$/ $1/mg for @diag; + } + + # Add the trailing ' {' to the 'ok' line of TAP output. + $ok->[1] =~ s/\n/ {\n/; + + # Render the sub-events, we use our own counter for these. + my $count = 0; + my @subs = map { + # Bump the count for any event that should bump it. + $count++ if $_->increments_count; + + # This indents all output lines generated for the sub-events. + # index 0 is the filehandle, index 1 is the message we want to indent. + map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($_, $count); + } @{$e->subevents}; + + return ( + $ok, # opening ok - name { + @diag, # diagnostics if the subtest failed + @subs, # All the inner-event lines + [OUT_STD(), "}\n"], # } (closing brace) + ); +} + +sub event_plan { + my $self = shift; + my ($e, $num) = @_; + + my $directive = $e->directive; + return if $directive && $directive eq 'NO PLAN'; + + my $reason = $e->reason; + $reason =~ s/\n/\n# /g if $reason; + + my $plan = "1.." . $e->max; + if ($directive) { + $plan .= " # $directive"; + $plan .= " $reason" if defined $reason; + } + + return [OUT_STD, "$plan\n"]; +} + +sub event_version { + my $self = shift; + my ($e, $num) = @_; + + my $version = $e->version; + + return [OUT_STD, "TAP version $version\n"]; +} + +sub event_other { + my $self = shift; + my ($e, $num) = @_; + return if $e->no_display; + + my @out; + + if (my ($max, $directive, $reason) = $e->sets_plan) { + my $plan = "1..$max"; + $plan .= " # $directive" if $directive; + $plan .= " $reason" if defined $reason; + push @out => [OUT_STD, "$plan\n"]; + } + + if ($e->increments_count) { + my $ok = ""; + $ok .= "not " if $e->causes_fail; + $ok .= "ok"; + $ok .= " $num" if defined($num); + $ok .= " - " . $e->summary if $e->summary; + + push @out => [OUT_STD, "$ok\n"]; + } + else { # Comment + my $handle = ($e->causes_fail || $e->diagnostics) ? OUT_ERR : OUT_STD; + my $summary = $e->summary || ref($e); + chomp($summary); + $summary =~ s/^/# /smg; + push @out => [$handle, "$summary\n"]; + } + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::TAP - Standard TAP formatter + +=head1 DESCRIPTION + +This is what takes events and turns them into TAP. + +=head1 SYNOPSIS + + use Test2::Formatter::TAP; + my $tap = Test2::Formatter::TAP->new(); + + # Switch to utf8 + $tap->encoding('utf8'); + + $tap->write($event, $number); # Output an event + +=head1 METHODS + +=over 4 + +=item $bool = $tap->no_numbers + +=item $tap->set_no_numbers($bool) + +Use to turn numbers on and off. + +=item $arrayref = $tap->handles + +=item $tap->set_handles(\@handles); + +Can be used to get/set the filehandles. Indexes are identified by the +C and C constants. + +=item $encoding = $tap->encoding + +=item $tap->encoding($encoding) + +Get or set the encoding. By default no encoding is set, the original settings +of STDOUT and STDERR are used. + +This directly modifies the stored filehandles, it does not create new ones. + +=item $tap->write($e, $num) + +Write an event to the console. + +=item Test2::Formatter::TAP->register_event($pkg, sub { ... }); + +In general custom events are not supported. There are however occasions where +you might want to write a custom event type that results in TAP output. In +order to do this you use the C class method. + + package My::Event; + use Test2::Formatter::TAP; + + use base 'Test2::Event'; + use Test2::Util::HashBase qw/pass name diag note/; + + Test2::Formatter::TAP->register_event( + __PACKAGE__, + sub { + my $self = shift; + my ($e, $num) = @_; + return ( + [Test2::Formatter::TAP::OUT_STD, "ok $num - " . $e->name . "\n"], + [Test2::Formatter::TAP::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"], + [Test2::Formatter::TAP::OUT_STD, "# " . $e->name . " " . $e->note . "\n"], + ); + } + ); + + 1; + +=back + +=head2 EVENT METHODS + +All these methods require the event itself. Optionally they can all except a +test number. + +All methods return a list of array-refs. Each array-ref will have 2 items, the +first is an integer identifying an output handle, the second is a string that +should be written to the handle. + +=over 4 + +=item @out = $TAP->event_ok($e) + +=item @out = $TAP->event_ok($e, $num) + +Process an L event. + +=item @out = $TAP->event_plan($e) + +=item @out = $TAP->event_plan($e, $num) + +Process an L event. + +=item @out = $TAP->event_note($e) + +=item @out = $TAP->event_note($e, $num) + +Process an L event. + +=item @out = $TAP->event_diag($e) + +=item @out = $TAP->event_diag($e, $num) + +Process an L event. + +=item @out = $TAP->event_bail($e) + +=item @out = $TAP->event_bail($e, $num) + +Process an L event. + +=item @out = $TAP->event_exception($e) + +=item @out = $TAP->event_exception($e, $num) + +Process an L event. + +=item @out = $TAP->event_skip($e) + +=item @out = $TAP->event_skip($e, $num) + +Process an L event. + +=item @out = $TAP->event_subtest($e) + +=item @out = $TAP->event_subtest($e, $num) + +Process an L event. + +=item @out = $TAP->event_other($e, $num) + +Fallback for unregistered event types. It uses the L API to +convert the event to TAP. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Hub.pm b/dist/Test-Simple/lib/Test2/Hub.pm new file mode 100644 index 00000000000..f25867b4ea3 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Hub.pm @@ -0,0 +1,829 @@ +package Test2::Hub; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Carp qw/carp croak confess/; +use Test2::Util qw/get_tid ipc_separator/; + +use Scalar::Util qw/weaken/; + +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util::HashBase qw{ + pid tid hid ipc + no_ending + _filters + _pre_filters + _listeners + _follow_ups + _formatter + _context_acquire + _context_init + _context_release + + active + count + failed + ended + bailed_out + _passing + _plan + skip_reason +}; + +my $ID_POSTFIX = 1; +sub init { + my $self = shift; + + $self->{+PID} = $$; + $self->{+TID} = get_tid(); + $self->{+HID} = join ipc_separator, $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; + + $self->{+COUNT} = 0; + $self->{+FAILED} = 0; + $self->{+_PASSING} = 1; + + if (my $formatter = delete $self->{formatter}) { + $self->format($formatter); + } + + if (my $ipc = $self->{+IPC}) { + $ipc->add_hub($self->{+HID}); + } +} + +sub is_subtest { 0 } + +sub reset_state { + my $self = shift; + + $self->{+COUNT} = 0; + $self->{+FAILED} = 0; + $self->{+_PASSING} = 1; + + delete $self->{+_PLAN}; + delete $self->{+ENDED}; + delete $self->{+BAILED_OUT}; + delete $self->{+SKIP_REASON}; +} + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + $self->{+_FORMATTER} = $from->{+_FORMATTER} + unless $self->{+_FORMATTER} || exists($params{formatter}); + + if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { + my $ipc = $from->{+IPC}; + $self->{+IPC} = $ipc; + $ipc->add_hub($self->{+HID}); + } + + if (my $ls = $from->{+_LISTENERS}) { + push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls; + } + + if (my $pfs = $from->{+_PRE_FILTERS}) { + push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs; + } + + if (my $fs = $from->{+_FILTERS}) { + push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs; + } +} + +sub format { + my $self = shift; + + my $old = $self->{+_FORMATTER}; + ($self->{+_FORMATTER}) = @_ if @_; + + return $old; +} + +sub is_local { + my $self = shift; + return $$ == $self->{+PID} + && get_tid() == $self->{+TID}; +} + +sub listen { + my $self = shift; + my ($sub, %params) = @_; + + carp "Useless addition of a listener in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "listen only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_LISTENERS}} => { %params, code => $sub }; + + $sub; # Intentional return. +} + +sub unlisten { + my $self = shift; + + carp "Useless removal of a listener in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + my %subs = map {$_ => $_} @_; + + @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}}; +} + +sub filter { + my $self = shift; + my ($sub, %params) = @_; + + carp "Useless addition of a filter in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "filter only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_FILTERS}} => { %params, code => $sub }; + + $sub; # Intentional Return +} + +sub unfilter { + my $self = shift; + carp "Useless removal of a filter in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + my %subs = map {$_ => $_} @_; + @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}}; +} + +sub pre_filter { + my $self = shift; + my ($sub, %params) = @_; + + croak "pre_filter only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub }; + + $sub; # Intentional Return +} + +sub pre_unfilter { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}}; +} + +sub follow_up { + my $self = shift; + my ($sub) = @_; + + carp "Useless addition of a follow-up in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "follow_up only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_FOLLOW_UPS}} => $sub; +} + +*add_context_aquire = \&add_context_acquire; +sub add_context_acquire { + my $self = shift; + my ($sub) = @_; + + croak "add_context_acquire only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_ACQUIRE}} => $sub; + + $sub; # Intentional return. +} + +*remove_context_aquire = \&remove_context_acquire; +sub remove_context_acquire { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}}; +} + +sub add_context_init { + my $self = shift; + my ($sub) = @_; + + croak "add_context_init only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_INIT}} => $sub; + + $sub; # Intentional return. +} + +sub remove_context_init { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}}; +} + +sub add_context_release { + my $self = shift; + my ($sub) = @_; + + croak "add_context_release only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_RELEASE}} => $sub; + + $sub; # Intentional return. +} + +sub remove_context_release { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}}; +} + +sub send { + my $self = shift; + my ($e) = @_; + + if ($self->{+_PRE_FILTERS}) { + for (@{$self->{+_PRE_FILTERS}}) { + $e = $_->{code}->($self, $e); + return unless $e; + } + } + + my $ipc = $self->{+IPC} || return $self->process($e); + + if($e->global) { + $ipc->send($self->{+HID}, $e, 'GLOBAL'); + return $self->process($e); + } + + return $ipc->send($self->{+HID}, $e) + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + $self->process($e); +} + +sub process { + my $self = shift; + my ($e) = @_; + + if ($self->{+_FILTERS}) { + for (@{$self->{+_FILTERS}}) { + $e = $_->{code}->($self, $e); + return unless $e; + } + } + + my $type = ref($e); + my $is_ok = $type eq 'Test2::Event::Ok'; + my $no_fail = $type eq 'Test2::Event::Diag' || $type eq 'Test2::Event::Note'; + my $causes_fail = $is_ok ? !$e->{effective_pass} : $no_fail ? 0 : $e->causes_fail; + my $counted = $is_ok || (!$no_fail && $e->increments_count); + + $self->{+COUNT}++ if $counted; + $self->{+FAILED}++ if $causes_fail && $counted; + $self->{+_PASSING} = 0 if $causes_fail; + + my $callback = $e->callback($self) unless $is_ok || $no_fail; + + my $count = $self->{+COUNT}; + + $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; + + if ($self->{+_LISTENERS}) { + $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; + } + + return $e if $is_ok || $no_fail; + + my $code = $e->terminate; + if (defined $code) { + $self->{+_FORMATTER}->terminate($e) if $self->{+_FORMATTER}; + $self->terminate($code, $e); + } + + return $e; +} + +sub terminate { + my $self = shift; + my ($code) = @_; + exit($code); +} + +sub cull { + my $self = shift; + + my $ipc = $self->{+IPC} || return; + return if $self->{+PID} != $$ || $self->{+TID} != get_tid(); + + # No need to do IPC checks on culled events + $self->process($_) for $ipc->cull($self->{+HID}); +} + +sub finalize { + my $self = shift; + my ($trace, $do_plan) = @_; + + $self->cull(); + + my $plan = $self->{+_PLAN}; + my $count = $self->{+COUNT}; + my $failed = $self->{+FAILED}; + my $active = $self->{+ACTIVE}; + + # return if NOTHING was done. + unless ($active || $do_plan || defined($plan) || $count || $failed) { + $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; + return; + } + + unless ($self->{+ENDED}) { + if ($self->{+_FOLLOW_UPS}) { + $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}}; + } + + # These need to be refreshed now + $plan = $self->{+_PLAN}; + $count = $self->{+COUNT}; + $failed = $self->{+FAILED}; + + if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) { + $self->send( + Test2::Event::Plan->new( + trace => $trace, + max => $count, + ) + ); + } + $plan = $self->{+_PLAN}; + } + + my $frame = $trace->frame; + if($self->{+ENDED}) { + my (undef, $ffile, $fline) = @{$self->{+ENDED}}; + my (undef, $sfile, $sline) = @$frame; + + die <<" EOT" +Test already ended! +First End: $ffile line $fline +Second End: $sfile line $sline + EOT + } + + $self->{+ENDED} = $frame; + my $pass = $self->is_passing(); # Generate the final boolean. + + $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; + + return $pass; +} + +sub is_passing { + my $self = shift; + + ($self->{+_PASSING}) = @_ if @_; + + # If we already failed just return 0. + my $pass = $self->{+_PASSING} or return 0; + return $self->{+_PASSING} = 0 if $self->{+FAILED}; + + my $count = $self->{+COUNT}; + my $ended = $self->{+ENDED}; + my $plan = $self->{+_PLAN}; + + return $pass if !$count && $plan && $plan =~ m/^SKIP$/; + + return $self->{+_PASSING} = 0 + if $ended && (!$count || !$plan); + + return $pass unless $plan && $plan =~ m/^\d+$/; + + if ($ended) { + return $self->{+_PASSING} = 0 if $count != $plan; + } + else { + return $self->{+_PASSING} = 0 if $count > $plan; + } + + return $pass; +} + +sub plan { + my $self = shift; + + return $self->{+_PLAN} unless @_; + + my ($plan) = @_; + + confess "You cannot unset the plan" + unless defined $plan; + + confess "You cannot change the plan" + if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/; + + confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'" + unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/; + + $self->{+_PLAN} = $plan; +} + +sub check_plan { + my $self = shift; + + return undef unless $self->{+ENDED}; + my $plan = $self->{+_PLAN} || return undef; + + return 1 if $plan !~ m/^\d+$/; + + return 1 if $plan == $self->{+COUNT}; + return 0; +} + +sub DESTROY { + my $self = shift; + my $ipc = $self->{+IPC} || return; + return unless $$ == $self->{+PID}; + return unless get_tid() == $self->{+TID}; + + $ipc->drop_hub($self->{+HID}); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub - The conduit through which all events flow. + +=head1 SYNOPSIS + + use Test2::Hub; + + my $hub = Test2::Hub->new(); + $hub->send(...); + +=head1 DESCRIPTION + +The hub is the place where all events get processed and handed off to the +formatter. The hub also tracks test state, and provides several hooks into the +event pipeline. + +=head1 COMMON TASKS + +=head2 SENDING EVENTS + + $hub->send($event) + +The C method is used to issue an event to the hub. This method will +handle thread/fork sync, filters, listeners, TAP output, etc. + +=head2 ALTERING OR REMOVING EVENTS + +You can use either C or C, depending on your +needs. Both have identical syntax, so only C is shown here. + + $hub->filter(sub { + my ($hub, $event) = @_; + + my $action = get_action($event); + + # No action should be taken + return $event if $action eq 'none'; + + # You want your filter to remove the event + return undef if $action eq 'delete'; + + if ($action eq 'do_it') { + my $new_event = copy_event($event); + ... Change your copy of the event ... + return $new_event; + } + + die "Should not happen"; + }); + +By default, filters are not inherited by child hubs. That means if you start a +subtest, the subtest will not inherit the filter. You can change this behavior +with the C parameter: + + $hub->filter(sub { ... }, inherit => 1); + +=head2 LISTENING FOR EVENTS + + $hub->listen(sub { + my ($hub, $event, $number) = @_; + + ... do whatever you want with the event ... + + # return is ignored + }); + +By default listeners are not inherited by child hubs. That means if you start a +subtest, the subtest will not inherit the listener. You can change this behavior +with the C parameter: + + $hub->listen(sub { ... }, inherit => 1); + + +=head2 POST-TEST BEHAVIORS + + $hub->follow_up(sub { + my ($trace, $hub) = @_; + + ... do whatever you need to ... + + # Return is ignored + }); + +follow_up subs are called only once, either when done_testing is called, or in +an END block. + +=head2 SETTING THE FORMATTER + +By default an instance of L is created and used. + + my $old = $hub->format(My::Formatter->new); + +Setting the formatter will REPLACE any existing formatter. You may set the +formatter to undef to prevent output. The old formatter will be returned if one +was already set. Only one formatter is allowed at a time. + +=head1 METHODS + +=over 4 + +=item $hub->send($event) + +This is where all events enter the hub for processing. + +=item $hub->process($event) + +This is called by send after it does any IPC handling. You can use this to +bypass the IPC process, but in general you should avoid using this. + +=item $old = $hub->format($formatter) + +Replace the existing formatter instance with a new one. Formatters must be +objects that implement a C<< $formatter->write($event) >> method. + +=item $sub = $hub->listen(sub { ... }, %optional_params) + +You can use this to record all events AFTER they have been sent to the +formatter. No changes made here will be meaningful, except possibly to other +listeners. + + $hub->listen(sub { + my ($hub, $event, $number) = @_; + + ... do whatever you want with the event ... + + # return is ignored + }); + +Normally listeners are not inherited by child hubs such as subtests. You can +add the C<< inherit => 1 >> parameter to allow a listener to be inherited. + +=item $hub->unlisten($sub) + +You can use this to remove a listen callback. You must pass in the coderef +returned by the C method. + +=item $sub = $hub->filter(sub { ... }, %optional_params) + +=item $sub = $hub->pre_filter(sub { ... }, %optional_params) + +These can be used to add filters. Filters can modify, replace, or remove events +before anything else can see them. + + $hub->filter( + sub { + my ($hub, $event) = @_; + + return $event; # No Changes + return; # Remove the event + + # Or you can modify an event before returning it. + $event->modify; + return $event; + } + ); + +If you are not using threads, forking, or IPC then the only difference between +a C and a C is that C subs run first. When you +are using threads, forking, or IPC, pre_filters happen to events before they +are sent to their destination proc/thread, ordinary filters happen only in the +destination hub/thread. + +You cannot add a regular filter to a hub if the hub was created in another +process or thread. You can always add a pre_filter. + +=item $hub->unfilter($sub) + +=item $hub->pre_unfilter($sub) + +These can be used to remove filters and pre_filters. The C<$sub> argument is +the reference returned by C or C. + +=item $hub->follow_op(sub { ... }) + +Use this to add behaviors that are called just before the hub is finalized. The +only argument to your codeblock will be a L instance. + + $hub->follow_up(sub { + my ($trace, $hub) = @_; + + ... do whatever you need to ... + + # Return is ignored + }); + +follow_up subs are called only once, ether when done_testing is called, or in +an END block. + +=item $sub = $hub->add_context_acquire(sub { ... }); + +Add a callback that will be called every time someone tries to acquire a +context. It gets a single argument, a reference of the hash of parameters +being used the construct the context. This is your chance to change the +parameters by directly altering the hash. + + test2_add_callback_context_acquire(sub { + my $params = shift; + $params->{level}++; + }); + +This is a very scary API function. Please do not use this unless you need to. +This is here for L and backwards compatibility. This has you +directly manipulate the hash instead of returning a new one for performance +reasons. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_acquire($sub); + +This can be used to remove a context acquire hook. + +=item $sub = $hub->add_context_init(sub { ... }); + +This allows you to add callbacks that will trigger every time a new context is +created for the hub. The only argument to the sub will be the +L instance that was created. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_init($sub); + +This can be used to remove a context init hook. + +=item $sub = $hub->add_context_release(sub { ... }); + +This allows you to add callbacks that will trigger every time a context for +this hub is released. The only argument to the sub will be the +L instance that was released. These will run in reverse +order. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_release($sub); + +This can be used to remove a context release hook. + +=item $hub->cull() + +Cull any IPC events (and process them). + +=item $pid = $hub->pid() + +Get the process id under which the hub was created. + +=item $tid = $hub->tid() + +Get the thread id under which the hub was created. + +=item $hud = $hub->hid() + +Get the identifier string of the hub. + +=item $ipc = $hub->ipc() + +Get the IPC object used by the hub. + +=item $hub->set_no_ending($bool) + +=item $bool = $hub->no_ending + +This can be used to disable auto-ending behavior for a hub. The auto-ending +behavior is triggered by an end block and is used to cull IPC events, and +output the final plan if the plan was 'no_plan'. + +=item $bool = $hub->active + +=item $hub->set_active($bool) + +These are used to get/set the 'active' attribute. When true this attribute will +force C<< hub->finalize() >> to take action even if there is no plan, and no +tests have been run. This flag is useful for plugins that add follow-up +behaviors that need to run even if no events are seen. + +=back + +=head2 STATE METHODS + +=over 4 + +=item $hub->reset_state() + +Reset all state to the start. This sets the test count to 0, clears the plan, +removes the failures, etc. + +=item $num = $hub->count + +Get the number of tests that have been run. + +=item $num = $hub->failed + +Get the number of failures (Not all failures come from a test fail, so this +number can be larger than the count). + +=item $bool = $hub->ended + +True if the testing has ended. This MAY return the stack frame of the tool that +ended the test, but that is not guaranteed. + +=item $bool = $hub->is_passing + +=item $hub->is_passing($bool) + +Check if the overall test run is a failure. Can also be used to set the +pass/fail status. + +=item $hub->plan($plan) + +=item $plan = $hub->plan + +Get or set the plan. The plan must be an integer larger than 0, the string +'no_plan', or the string 'skip_all'. + +=item $bool = $hub->check_plan + +Check if the plan and counts match, but only if the tests have ended. If tests +have not ended this will return undef, otherwise it will be a true/false. + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Hub/Interceptor.pm b/dist/Test-Simple/lib/Test2/Hub/Interceptor.pm new file mode 100644 index 00000000000..f811223de6e --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Hub/Interceptor.pm @@ -0,0 +1,80 @@ +package Test2::Hub::Interceptor; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Test2::Hub::Interceptor::Terminator(); + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase; + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { + my $ipc = $from->{+IPC}; + $self->{+IPC} = $ipc; + $ipc->add_hub($self->{+HID}); + } +} + +sub terminate { + my $self = shift; + my ($code) = @_; + + eval { + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; + }; + my $err = $@; + + # Fallback + die bless(\$err, 'Test2::Hub::Interceptor::Terminator'); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Interceptor - Hub used by interceptor to grab results. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm b/dist/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm new file mode 100644 index 00000000000..c656bc4b9b0 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm @@ -0,0 +1,51 @@ +package Test2::Hub::Interceptor::Terminator; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Interceptor::Terminator - Exception class used by +Test2::Hub::Interceptor + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Hub/Subtest.pm b/dist/Test-Simple/lib/Test2/Hub/Subtest.pm new file mode 100644 index 00000000000..09db8c0f188 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Hub/Subtest.pm @@ -0,0 +1,125 @@ +package Test2::Hub::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase qw/nested bailed_out exit_code manual_skip_all id/; +use Test2::Util qw/get_tid/; + +my $ID = 1; +sub init { + my $self = shift; + $self->SUPER::init(@_); + $self->{+ID} ||= join "-", $$, get_tid, $ID++; +} + +sub is_subtest { 1 } + +sub process { + my $self = shift; + my ($e) = @_; + $e->set_nested($self->nested); + $e->set_in_subtest($self->{+ID}); + $self->set_bailed_out($e) if $e->isa('Test2::Event::Bail'); + $self->SUPER::process($e); +} + +sub send { + my $self = shift; + my ($e) = @_; + + my $out = $self->SUPER::send($e); + + return $out if $self->{+MANUAL_SKIP_ALL}; + return $out unless $e->isa('Test2::Event::Plan') + && $e->directive eq 'SKIP' + && ($e->trace->pid != $self->pid || $e->trace->tid != $self->tid); + + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; +} + +sub terminate { + my $self = shift; + my ($code, $e) = @_; + $self->set_exit_code($code); + + return if $self->{+MANUAL_SKIP_ALL}; + return if $e->isa('Test2::Event::Plan') + && $e->directive eq 'SKIP' + && ($e->trace->pid != $$ || $e->trace->tid != get_tid); + + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Subtest - Hub used by subtests + +=head1 DESCRIPTION + +Subtests make use of this hub to route events. + +=head1 TOGGLES + +=over 4 + +=item $bool = $hub->manual_skip_all + +=item $hub->set_manual_skip_all($bool) + +The default is false. + +Normally a skip-all plan event will cause a subtest to stop executing. This is +accomplished via C to a label inside the subtest code. Most of the +time this is perfectly fine. There are times however where this flow control +causes bad things to happen. + +This toggle lets you turn off the abort logic for the hub. When this is toggled +to true B are responsible for ensuring no additional events are generated. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/IPC.pm b/dist/Test-Simple/lib/Test2/IPC.pm new file mode 100644 index 00000000000..84067a82a4a --- /dev/null +++ b/dist/Test-Simple/lib/Test2/IPC.pm @@ -0,0 +1,140 @@ +package Test2::IPC; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Test2::API::Instance; +use Test2::Util qw/get_tid/; +use Test2::API qw{ + test2_init_done + test2_ipc + test2_ipc_enable_polling + test2_pid + test2_stack + test2_tid + context +}; + +use Carp qw/confess/; + +our @EXPORT_OK = qw/cull/; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub import { + goto &Exporter::import unless test2_init_done(); + + confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$; + confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid(); + + Test2::API::_set_ipc(_make_ipc()); + apply_ipc(test2_stack()); + + goto &Exporter::import; +} + +sub _make_ipc { + # Find a driver + my ($driver) = Test2::API::test2_ipc_drivers(); + unless ($driver) { + require Test2::IPC::Driver::Files; + $driver = 'Test2::IPC::Driver::Files'; + } + + return $driver->new(); +} + +sub apply_ipc { + my $stack = shift; + + my ($root) = @$stack; + + return unless $root; + + confess "Cannot add IPC in a child process" if $root->pid != $$; + confess "Cannot add IPC in a child thread" if $root->tid != get_tid(); + + my $ipc = $root->ipc || test2_ipc() || _make_ipc(); + + # Add the IPC to all hubs + for my $hub (@$stack) { + my $has = $hub->ipc; + confess "IPC Mismatch!" if $has && $has != $ipc; + next if $has; + $hub->set_ipc($ipc); + $ipc->add_hub($hub->hid); + } + + test2_ipc_enable_polling(); + + return $ipc; +} + +sub cull { + my $ctx = context(); + $ctx->hub->cull; + $ctx->release; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC - Turn on IPC for threading or forking support. + +=head1 SYNOPSIS + +You should C as early as possible in your test file. If you +import this module after API initialization it will attempt to retrofit IPC +onto the existing hubs. + +=head1 EXPORTS + +All exports are optional. + +=over 4 + +=item cull() + +Cull allows you to collect results from other processes or threads on demand. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/IPC/Driver.pm b/dist/Test-Simple/lib/Test2/IPC/Driver.pm new file mode 100644 index 00000000000..460b83acab5 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/IPC/Driver.pm @@ -0,0 +1,292 @@ +package Test2::IPC::Driver; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Carp qw/confess longmess/; +use Test2::Util::HashBase qw{no_fatal}; + +use Test2::API qw/test2_ipc_add_driver/; + +my %ADDED; +sub import { + my $class = shift; + return if $class eq __PACKAGE__; + return if $ADDED{$class}++; + test2_ipc_add_driver($class); +} + +sub use_shm { 0 } + +for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { + no strict 'refs'; + *$meth = sub { + my $thing = shift; + confess "'$thing' did not define the required method '$meth'." + }; +} + +# Print the error and call exit. We are not using 'die' cause this is a +# catastrophic error that should never be caught. If we get here it +# means some serious shit has happened in a child process, the only way +# to inform the parent may be to exit false. + +sub abort { + my $self = shift; + chomp(my ($msg) = @_); + print STDERR "IPC Fatal Error: $msg\n"; + print STDOUT "not ok - IPC Fatal Error\n"; + + CORE::exit(255) unless $self->no_fatal; +} + +sub abort_trace { + my $self = shift; + my ($msg) = @_; + $self->abort(longmess($msg)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC::Driver - Base class for Test2 IPC drivers. + +=head1 SYNOPSIS + + package Test2::IPC::Driver::MyDriver; + + use base 'Test2::IPC::Driver'; + + ... + +=head1 METHODS + +=over 4 + +=item $self->abort($msg) + +If an IPC encounters a fatal error it should use this. This will print the +message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will +forcefully exit 255. IPC errors may occur in threads or processes other than +the main one, this method provides the best chance of the harness noticing the +error. + +=item $self->abort_trace($msg) + +This is the same as C<< $ipc->abort($msg) >> except that it uses +C to add a stack trace to the message. + +=item $false = $self->use_shm + +The base class always returns false for this method. You may override it if you +wish to use the SHM made available in L/L. + +=back + +=head1 LOADING DRIVERS + +Test2::IPC::Driver has an C method. All drivers inherit this import +method. This import method registers the driver. + +In most cases you just need to load the desired IPC driver to make it work. You +should load this driver as early as possible. A warning will be issued if you +load it too late for it to be effective. + + use Test2::IPC::Driver::MyDriver; + ... + +=head1 WRITING DRIVERS + + package Test2::IPC::Driver::MyDriver; + use strict; + use warnings; + + use base 'Test2::IPC::Driver'; + + sub is_viable { + return 0 if $^O eq 'win32'; # Will not work on windows. + return 1; + } + + sub add_hub { + my $self = shift; + my ($hid) = @_; + + ... # Make it possible to contact the hub + } + + sub drop_hub { + my $self = shift; + my ($hid) = @_; + + ... # Nothing should try to reach the hub anymore. + } + + sub send { + my $self = shift; + my ($hid, $e, $global) = @_; + + ... # Send the event to the proper hub. + + # If you are using the SHM you should notify other procs/threads that + # there is a pending event. + Test2::API::test2_ipc_set_pending($uniq_val); + } + + sub cull { + my $self = shift; + my ($hid) = @_; + + my @events = ...; # Here is where you get the events for the hub + + return @events; + } + + sub waiting { + my $self = shift; + + ... # Notify all listening procs and threads that the main + ... # process/thread is waiting for them to finish. + } + + 1; + +=head2 METHODS SUBCLASSES MUST IMPLEMENT + +=over 4 + +=item $ipc->is_viable + +This should return true if the driver works in the current environment. This +should return false if it does not. This is a CLASS method. + +=item $ipc->add_hub($hid) + +This is used to alert the driver that a new hub is expecting events. The driver +should keep track of the process and thread ids, the hub should only be dropped +by the proc+thread that started it. + + sub add_hub { + my $self = shift; + my ($hid) = @_; + + ... # Make it possible to contact the hub + } + +=item $ipc->drop_hub($hid) + +This is used to alert the driver that a hub is no longer accepting events. The +driver should keep track of the process and thread ids, the hub should only be +dropped by the proc+thread that started it (This is the drivers responsibility +to enforce). + + sub drop_hub { + my $self = shift; + my ($hid) = @_; + + ... # Nothing should try to reach the hub anymore. + } + +=item $ipc->send($hid, $event); + +=item $ipc->send($hid, $event, $global); + +Used to send events from the current process/thread to the specified hub in its +process+thread. + + sub send { + my $self = shift; + my ($hid, $e) = @_; + + ... # Send the event to the proper hub. + + # If you are using the SHM you should notify other procs/threads that + # there is a pending event. + Test2::API::test2_ipc_set_pending($uniq_val); + } + +If C<$global> is true then the driver should send the event to all hubs in all +processes and threads. + +=item @events = $ipc->cull($hid) + +Used to collect events that have been sent to the specified hub. + + sub cull { + my $self = shift; + my ($hid) = @_; + + my @events = ...; # Here is where you get the events for the hub + + return @events; + } + +=item $ipc->waiting() + +This is called in the parent process when it is complete and waiting for all +child processes and threads to complete. + + sub waiting { + my $self = shift; + + ... # Notify all listening procs and threads that the main + ... # process/thread is waiting for them to finish. + } + +=back + +=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE + +=over 4 + +=item $bool = $ipc->use_shm() + +True if you want to make use of the L/L SHM. + +=item $bites = $ipc->shm_size() + +Use this to customize the size of the SHM space. There are no guarantees about +what the size will be if you do not implement this. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/IPC/Driver/Files.pm b/dist/Test-Simple/lib/Test2/IPC/Driver/Files.pm new file mode 100644 index 00000000000..74d3f5ca91e --- /dev/null +++ b/dist/Test-Simple/lib/Test2/IPC/Driver/Files.pm @@ -0,0 +1,497 @@ +package Test2::IPC::Driver::Files; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } + +use Test2::Util::HashBase qw{tempdir event_id tid pid globals}; + +use Scalar::Util qw/blessed/; +use File::Temp(); +use Storable(); +use File::Spec(); +use POSIX(); + +use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator/; +use Test2::API qw/test2_ipc_set_pending/; + +BEGIN { + if (IS_WIN32) { + my $max_tries = 5; + + *do_rename = sub { + my ($from, $to) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if rename($from, $to); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, $err); + }; + *do_unlink = sub { + my ($file) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if unlink($file); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, "$!"); + }; + } + else { + *do_rename = sub { + my ($from, $to) = @_; + return (1) if rename($from, $to); + return (0, "$!"); + }; + *do_unlink = sub { + my ($file) = @_; + return (1) if unlink($file); + return (0, "$!"); + }; + } +} + +sub use_shm { 1 } +sub shm_size() { 64 } + +sub is_viable { 1 } + +sub init { + my $self = shift; + + my $tmpdir = File::Temp::tempdir( + $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX", + CLEANUP => 0, + TMPDIR => 1, + ); + + $self->abort_trace("Could not get a temp dir") unless $tmpdir; + + $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); + + print STDERR "\nIPC Temp Dir: $tmpdir\n\n" + if $ENV{T2_KEEP_TEMPDIR}; + + $self->{+EVENT_ID} = 1; + + $self->{+TID} = get_tid(); + $self->{+PID} = $$; + + $self->{+GLOBALS} = {}; + + return $self; +} + +sub hub_file { + my $self = shift; + my ($hid) = @_; + my $tdir = $self->{+TEMPDIR}; + return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid); +} + +sub event_file { + my $self = shift; + my ($hid, $e) = @_; + + my $tempdir = $self->{+TEMPDIR}; + my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); + + $self->abort("'$e' is not an event object!") + unless $type->isa('Test2::Event'); + + my @type = split '::', $type; + my $name = join(ipc_separator, $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type); + + return File::Spec->catfile($tempdir, $name); +} + +sub add_hub { + my $self = shift; + my ($hid) = @_; + + my $hfile = $self->hub_file($hid); + + $self->abort_trace("File for hub '$hid' already exists") + if -e $hfile; + + open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!"); + print $fh "$$\n" . get_tid() . "\n"; + close($fh); +} + +sub drop_hub { + my $self = shift; + my ($hid) = @_; + + my $tdir = $self->{+TEMPDIR}; + my $hfile = $self->hub_file($hid); + + $self->abort_trace("File for hub '$hid' does not exist") + unless -e $hfile; + + open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!"); + my ($pid, $tid) = <$fh>; + close($fh); + + $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$") + unless $pid == $$; + + $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid()) + unless get_tid() == $tid; + + if ($ENV{T2_KEEP_TEMPDIR}) { + my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete")); + $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok + } + else { + my ($ok, $err) = do_unlink($hfile); + $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok + } + + opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); + for my $file (readdir($dh)) { + next if $file =~ m{\.complete$}; + next unless $file =~ m{^$hid}; + $self->abort_trace("Not all files from hub '$hid' have been collected!"); + } + closedir($dh); +} + +sub send { + my $self = shift; + my ($hid, $e, $global) = @_; + + my $tempdir = $self->{+TEMPDIR}; + my $hfile = $self->hub_file($hid); + my $dest = $global ? 'GLOBAL' : $hid; + + $self->abort(<<" EOT") unless $global || -f $hfile; +hub '$hid' is not available, failed to send event! + +There was an attempt to send an event to a hub in a parent process or thread, +but that hub appears to be gone. This can happen if you fork, or start a new +thread from inside subtest, and the parent finishes the subtest before the +child returns. + +This can also happen if the parent process is done testing before the child +finishes. Test2 normally waits automatically in the root process, but will not +do so if Test::Builder is loaded for legacy reasons. + EOT + + my $file = $self->event_file($dest, $e); + my $ready = File::Spec->canonpath("$file.ready"); + + if ($global) { + my $name = $ready; + $name =~ s{^.*(GLOBAL)}{GLOBAL}; + $self->{+GLOBALS}->{$hid}->{$name}++; + } + + my ($old, $blocked); + unless(IS_WIN32) { + my $to_block = POSIX::SigSet->new( + POSIX::SIGINT(), + POSIX::SIGALRM(), + POSIX::SIGHUP(), + POSIX::SIGTERM(), + POSIX::SIGUSR1(), + POSIX::SIGUSR2(), + ); + $old = POSIX::SigSet->new; + $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); + # Silently go on if we failed to log signals, not much we can do. + } + + # Write and rename the file. + my ($ok, $err) = try { + Storable::store($e, $file); + my ($ok, $err) = do_rename("$file", $ready); + unless ($ok) { + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + $self->abort("Could not rename file '$file' -> '$ready': $err"); + }; + test2_ipc_set_pending(substr($file, -(shm_size))); + }; + + # If our block was successful we want to restore the old mask. + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + + if (!$ok) { + my $src_file = __FILE__; + $err =~ s{ at \Q$src_file\E.*$}{}; + chomp($err); + my $tid = get_tid(); + my $trace = $e->trace->debug; + my $type = blessed($e); + + $self->abort(<<" EOT"); + +******************************************************************************* +There was an error writing an event: +Destination: $dest +Origin PID: $$ +Origin TID: $tid +Event Type: $type +Event Trace: $trace +File Name: $file +Ready Name: $ready +Error: $err +******************************************************************************* + + EOT + } + + return 1; +} + +sub cull { + my $self = shift; + my ($hid) = @_; + + my $tempdir = $self->{+TEMPDIR}; + + opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); + + my @out; + for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) { + my $full = $info->{full_path}; + my $obj = $self->read_event_file($full); + push @out => $obj; + + # Do not remove global events + next if $info->{global}; + + if ($ENV{T2_KEEP_TEMPDIR}) { + my $complete = File::Spec->canonpath("$full.complete"); + my ($ok, $err) = do_rename($full, $complete); + $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok; + } + else { + my ($ok, $err) = do_unlink("$full"); + $self->abort("Could not unlink IPC file '$full': $err") unless $ok; + } + } + + closedir($dh); + return @out; +} + +sub parse_event_filename { + my $self = shift; + my ($file) = @_; + + # The || is to force 0 in false + my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, ""); + my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, ""); + + my @parts = split ipc_separator, $file; + my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 3)); + my ($pid, $tid, $eid) = splice(@parts, 0, 3); + my $type = join '::' => @parts; + + return { + ready => $ready, + complete => $complete, + global => $global, + type => $type, + hid => $hid, + pid => $pid, + tid => $tid, + eid => $eid, + }; +} + +sub should_read_event { + my $self = shift; + my ($hid, $file) = @_; + + return if substr($file, 0, 1) eq '.'; + + my $parsed = $self->parse_event_filename($file); + + return if $parsed->{complete}; + return unless $parsed->{ready}; + return unless $parsed->{global} || $parsed->{hid} eq $hid; + + return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++; + + # Untaint the path. + my $full = File::Spec->catfile($self->{+TEMPDIR}, $file); + ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT}; + + $parsed->{full_path} = $full; + + return $parsed; +} + +sub cmp_events { + # Globals first + return -1 if $a->{global} && !$b->{global}; + return 1 if $b->{global} && !$a->{global}; + + return $a->{pid} <=> $b->{pid} + || $a->{tid} <=> $b->{tid} + || $a->{eid} <=> $b->{eid}; +} + +sub read_event_file { + my $self = shift; + my ($file) = @_; + + my $obj = Storable::retrieve($file); + $self->abort("Got an unblessed object: '$obj'") + unless blessed($obj); + + unless ($obj->isa('Test2::Event')) { + my $pkg = blessed($obj); + my $mod_file = pkg_to_file($pkg); + my ($ok, $err) = try { require $mod_file }; + + $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") + unless $ok; + + $self->abort("'$obj' is not a 'Test2::Event' object") + unless $obj->isa('Test2::Event'); + } + + return $obj; +} + +sub waiting { + my $self = shift; + require Test2::Event::Waiting; + $self->send( + GLOBAL => Test2::Event::Waiting->new( + trace => Test2::Util::Trace->new(frame => [caller()]), + ), + 'GLOBAL' + ); + return; +} + +sub DESTROY { + my $self = shift; + + return unless defined $self->pid; + return unless defined $self->tid; + + return unless $$ == $self->pid; + return unless get_tid() == $self->tid; + + my $tempdir = $self->{+TEMPDIR}; + + opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); + while(my $file = readdir($dh)) { + next if $file =~ m/^\.+$/; + next if $file =~ m/\.complete$/; + my $full = File::Spec->catfile($tempdir, $file); + + my $sep = ipc_separator; + if ($file =~ m/^(GLOBAL|HUB$sep)/) { + $full =~ m/^(.*)$/; + $full = $1; # Untaint it + next if $ENV{T2_KEEP_TEMPDIR}; + my ($ok, $err) = do_unlink($full); + $self->abort("Could not unlink IPC file '$full': $err") unless $ok; + next; + } + + $self->abort("Leftover files in the directory ($full)!\n"); + } + closedir($dh); + + if ($ENV{T2_KEEP_TEMPDIR}) { + print STDERR "# Not removing temp dir: $tempdir\n"; + return; + } + + rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC::Driver::Files - Temp dir + Files concurrency model. + +=head1 DESCRIPTION + +This is the default, and fallback concurrency model for L. This +sends events between processes and threads using serialized files in a +temporary directory. This is not particularly fast, but it works everywhere. + +=head1 SYNOPSIS + + use Test2::IPC::Driver::Files; + + # IPC is now enabled + +=head1 ENVIRONMENT VARIABLES + +=over 4 + +=item T2_KEEP_TEMPDIR=0 + +When true, the tempdir used by the IPC driver will not be deleted when the test +is done. + +=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX' + +This can be used to set the template for the IPC temp dir. The template should +follow template specifications from L. + +=back + +=head1 SEE ALSO + +See L for methods. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Tools/Tiny.pm b/dist/Test-Simple/lib/Test2/Tools/Tiny.pm new file mode 100644 index 00000000000..50866b3680a --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Tools/Tiny.pm @@ -0,0 +1,425 @@ +package Test2::Tools::Tiny; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; + +use Test2::Util qw/try/; +use Test2::API qw/context run_subtest test2_stack/; + +use Test2::Hub::Interceptor(); +use Test2::Hub::Interceptor::Terminator(); + +our $VERSION = '1.302075'; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } +our @EXPORT = qw{ + ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing + warnings exception tests capture +}; + +sub ok($;$@) { + my ($bool, $name, @diag) = @_; + my $ctx = context(); + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool ? 1 : 0; +} + +sub is($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" eq "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 0; + } + else { # Both are undef + $bool = 1; + } + + unless ($bool) { + $got = '*NOT DEFINED*' unless defined $got; + $want = '*NOT DEFINED*' unless defined $want; + unshift @diag => ( + "GOT: $got", + "EXPECTED: $want", + ); + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub isnt($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" ne "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 1; + } + else { # Both are undef + $bool = 0; + } + + unshift @diag => "Strings are the same (they should not be)" + unless $bool; + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub like($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" =~ $pattern; + unshift @diag => ( + "Value: $thing", + "Does not match: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub unlike($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" !~ $pattern; + unshift @diag => ( + "Unexpected pattern match (it should not match)", + "Value: $thing", + "Matches: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub is_deeply($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + no warnings 'once'; + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Deparse = 1; + local $Data::Dumper::Freezer = 'XXX'; + local *UNIVERSAL::XXX = sub { + my ($thing) = @_; + if (ref($thing)) { + $thing = {%$thing} if "$thing" =~ m/=HASH/; + $thing = [@$thing] if "$thing" =~ m/=ARRAY/; + $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; + } + $_[0] = $thing; + }; + + my $g = Data::Dumper::Dumper($got); + my $w = Data::Dumper::Dumper($want); + + my $bool = $g eq $w; + + my $diff; + + $ctx->ok($bool, $name, [$diff ? $diff : ($g, $w), @diag]); + $ctx->release; + return $bool; +} + +sub diag { + my $ctx = context(); + $ctx->diag(join '', @_); + $ctx->release; +} + +sub note { + my $ctx = context(); + $ctx->note(join '', @_); + $ctx->release; +} + +sub skip_all { + my ($reason) = @_; + my $ctx = context(); + $ctx->plan(0, SKIP => $reason); + $ctx->release if $ctx; +} + +sub todo { + my ($reason, $sub) = @_; + my $ctx = context(); + + # This code is mostly copied from Test2::Todo in the Test2-Suite + # distribution. + my $hub = test2_stack->top; + my $filter = $hub->pre_filter( + sub { + my ($active_hub, $event) = @_; + + # Turn a diag into a note + return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag'; + + # Set todo on ok's + if ($hub == $active_hub && $event->isa('Test2::Event::Ok')) { + $event->set_todo($reason); + $event->set_effective_pass(1); + } + + return $event; + }, + inherit => 1, + todo => $reason, + ); + $sub->(); + $hub->pre_unfilter($filter); + + $ctx->release if $ctx; +} + +sub plan { + my ($max) = @_; + my $ctx = context(); + $ctx->plan($max); + $ctx->release; +} + +sub done_testing { + my $ctx = context(); + $ctx->done_testing; + $ctx->release; +} + +sub warnings(&) { + my $code = shift; + my @warnings; + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $code->(); + return \@warnings; +} + +sub exception(&) { + my $code = shift; + local ($@, $!, $SIG{__DIE__}); + my $ok = eval { $code->(); 1 }; + my $error = $@ || 'SQUASHED ERROR'; + return $ok ? undef : $error; +} + +sub tests { + my ($name, $code) = @_; + my $ctx = context(); + + before_each() if __PACKAGE__->can('before_each'); + + my $bool = run_subtest($name, $code, 1); + + $ctx->release; + + return $bool; +} + +sub capture(&) { + my $code = shift; + + my ($err, $out) = ("", ""); + + my $handles = test2_stack->top->format->handles; + my ($ok, $e); + { + my ($out_fh, $err_fh); + + ($ok, $e) = try { + open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; + open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; + + test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); + + $code->(); + }; + } + test2_stack->top->format->set_handles($handles); + + die $e unless $ok; + + $err =~ s/ $/_/mg; + $out =~ s/ $/_/mg; + + return { + STDOUT => $out, + STDERR => $err, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use +L. + +=head1 DESCRIPTION + +You should really look at L. This package is some very basic +essential tools implemented using L. This exists only so that L +and other tools required by L can be tested. This is the package +L uses to test itself. + +=head1 USE Test2::Suite INSTEAD + +Use L if at all possible. + +=head1 EXPORTS + +=over 4 + +=item ok($bool, $name) + +=item ok($bool, $name, @diag) + +Run a simple assertion. + +=item is($got, $want, $name) + +=item is($got, $want, $name, @diag) + +Assert that 2 strings are the same. + +=item isnt($got, $do_not_want, $name) + +=item isnt($got, $do_not_want, $name, @diag) + +Assert that 2 strings are not the same. + +=item like($got, $regex, $name) + +=item like($got, $regex, $name, @diag) + +Check that the input string matches the regex. + +=item unlike($got, $regex, $name) + +=item unlike($got, $regex, $name, @diag) + +Check that the input string does not match the regex. + +=item is_deeply($got, $want, $name) + +=item is_deeply($got, $want, $name, @diag) + +Check 2 data structures. Please note that this is a I implementation that +compares the output of L against both structures. + +=item diag($msg) + +Issue a diagnostics message to STDERR. + +=item note($msg) + +Issue a diagnostics message to STDOUT. + +=item skip_all($reason) + +Skip all tests. + +=item todo $reason => sub { ... } + +Run a block in TODO mode. + +=item plan($count) + +Set the plan. + +=item done_testing() + +Set the plan to the current test count. + +=item $warnings = warnings { ... } + +Capture an arrayref of warnings from the block. + +=item $exception = exception { ... } + +Capture an exception. + +=item tests $name => sub { ... } + +Run a subtest. + +=item $output = capture { ... } + +Capture STDOUT and STDERR output. + +Result looks like this: + + { + STDOUT => "...", + STDERR => "...", + } + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Transition.pod b/dist/Test-Simple/lib/Test2/Transition.pod new file mode 100644 index 00000000000..95f9d77e9b1 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Transition.pod @@ -0,0 +1,512 @@ +=pod + +=head1 NAME + +Test2::Transition - Transition notes when upgrading to Test2 + +=head1 DESCRIPTION + +This is where gotchas and breakages related to the Test2 upgrade are +documented. The upgrade causes Test::Builder to defer to Test2 under the hood. +This transition is mostly transparent, but there are a few cases that can trip +you up. + +=head1 THINGS THAT BREAK + +This is the list of scenarios that break with the new internals. + +=head2 Test::Builder1.5/2 conditionals + +=head3 The Problem + +a few years back there were two attempts to upgrade/replace Test::Builder. +Confusingly these were called Test::Builder2 and Test::Builder1.5, in that +order. Many people put conditionals in their code to check the Test::Builder +version number and adapt their code accordingly. + +The Test::Builder2/1.5 projects both died out. Now the conditional code people +added has become a mine field. A vast majority of modules broken by Test2 fall +into this category. + +=head3 The Fix + +The fix is to remove all Test::Builder1.5/2 related code. Either use the +legacy Test::Builder API, or use Test2 directly. + +=head2 Replacing the Test::Builder singleton + +=head3 The Problem + +Some test modules would replace the Test::Builder singleton instance with their +own instance or subclass. This was usually done to intercept or modify results +as they happened. + +The Test::Builder singleton is now a simple compatibility wrapper around +Test2. The Test::Builder singleton is no longer the central place for +results. Many results bypass the Test::Builder singleton completely, which +breaks and behavior intended when replacing the singleton. + +=head3 The Fix + +If you simply want to intercept all results instead of letting them go to TAP, +you should look at the L docs and read about pushing a new hub onto +the hub stack. Replacing the hub temporarily is now the correct way to +intercept results. + +If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >> +method exported by Test::More to watch events as they are fired. If you wish to +modify results before they go to TAP look at the C<< Test2::Hub->filter() >> +method. + +=head2 Directly Accessing Hash Elements + +=head3 The Problem + +Some modules look directly at hash keys on the Test::Builder singleton. The +problem here is that the Test::Builder singleton no longer holds anything +important. + +=head3 The Fix + +The fix is to use the API specified in L to look at or modify state +as needed. + +=head2 Subtest indentation + +=head3 The Problem + +An early change, in fact the change that made Test2 an idea, was a change to +the indentation of the subtest note. IT was decided it would be more readable +to outdent the subtest note instead of having it inline with the subtest: + + # subtest foo + ok 1 - blah + 1..1 + ok 1 - subtest foo + +The old style indented the note: + + # subtest foo + ok 1 - blah + 1..1 + ok 1 - subtest foo + +This breaks tests that do string comparison of TAP output. + +=head3 The Fix + + my $indent = $INC{'Test2/API.pm'} ? '' : ' '; + + is( + $subtest_output, + "${indent}# subtest foo", + "Got subtest note" + ); + +Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be +expected. If it is not set than the old Test::Builder is in use, indentation +should be expected. + +=head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED + +This is a list of cpan modules that have been known to have been broken by the +upgrade at one point. + +=head2 WORKS BUT TESTS WILL FAIL + +These modules still function correctly, but their test suites will not pass. If +you already have these modules installed then you can continue to use them. If +you are trying to install them after upgrading Test::Builder you will need to +force installation, or bypass the broken tests. + +=over 4 + +=item Test::DBIx::Class::Schema + +This module has a test that appears to work around a Test::Builder bug. The bug +appears to have been fixed by Test2, which means the workaround causes a +failure. This can be easily updated, but nobody has done so yet. + +Known broken in versions: 1.0.9 and older + +=item Test::Kit + +This actually works fine, but will not install because L is in +the dependency chain. + +See the L info below for additional information. + +=item Device::Chip + +Tests break due to subtest indentation. + +Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has +been submitted to fix the issue. + +=back + +=head2 UPGRADE SUGGESTED + +These are modules that did not break, but had broken test suites that have +since been fixed. + +=over 4 + +=item Test::Exception + +Old versions work fine, but have a minor test name behavior that breaks with +Test2. Old versions will no longer install because of this. The latest version +on CPAN will install just fine. Upgrading is not required, but is recommended. + +Fixed in version: 0.43 + +=item Data::Peek + +Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch +was applied to correct things that changed. + +The module itself works fine, there is no need to upgrade. + +Fixed in version: 0.45 + +=item circular::require + +Some tests were fragile and required base.pm to be loaded at a late stage. +Test2 was loading base.pm too early. The tests were updated to fix this. + +The module itself never broke, you do not need to upgrade. + +Fixed in version: 0.12 + +=item Test::Module::Used + +A test worked around a now-fixed planning bug. There is no need to upgrade if +you have an old version installed. New versions install fine if you want them. + +Fixed in version: 0.2.5 + +=item Test::Moose::More + +Some tests were fragile, but have been fixed. The actual breakage was from the +subtest comment indentation change. + +No need to upgrade, old versions work fine. Only new versions will install. + +Fixed in version: 0.025 + +=item Test::FITesque + +This was broken by a bugfix to how planning is done. The test was updated after +the bugfix. + +Fixed in version: 0.04 + +=item autouse + +A test broke because it depended on Scalar::Util not being loaded. Test2 loads +Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's +load status. + +There is no need to upgrade if you already have it installed. + +Fixed in version: 1.11 + +=back + +=head2 NEED TO UPGRADE + +=over 4 + +=item Test::SharedFork + +Old versions need to directly access Test::Builder singleton hash elements. The +latest version on CPAN will still do this on old Test::Builder, but will defer +to L on Test2. + +Fixed in version: 0.35 + +=item Test::Builder::Clutch + +This works by doing overriding methods on the singleton, and directly accessing +hash values on the singleton. A new version has been released that uses the +Test2 API to accomplish the same result in a saner way. + +Fixed in version: 0.07 + +=item Test::Dist::VersionSync + +This had Test::Builder2 conditionals. This was fixed by removing the +conditionals. + +Fixed in version: 1.1.4 + +=item Test::Modern + +This relied on C<< Test::Builder->_try() >> which was a private method, +documented as something nobody should use. This was fixed by using a different +tool. + +Fixed in version: 0.012 + +=item Test::UseAllModules + +Version 0.14 relied on C<< Test::Builder->history >> which was available in +Test::Builder 1.5. Versions 0.12 and 0.13 relied on other Test::Builder +internals. + +Fixed in version: 0.15 + +=back + +=head2 STILL BROKEN + +=over 4 + +=item Test::Aggregate + +This distribution directly accesses the hash keys in the L +singleton. It also approaches the problem from the wrong angle, please consider +using L or L which both solve the same problem +at the harness level. + +Still broken as of version: 0.373 + +=item Test::Wrapper + +This module directly uses hash keys in the L singleton. This +module is also obsolete thanks to the benefits of L. Use C +from L to achieve a similar result. + +Still broken as of version: 0.3.0 + +=item Test::ParallelSubtest + +This module overrides C and +C. It also directly accesses hash elements of +the singleton. It has not yet been fixed. + +Alternatives: L and L (not stable). + +Still broken as of version: 0.05 + +=item Test::Pretty + +See https://github.com/tokuhirom/Test-Pretty/issues/25 + +The author admits the module is crazy, and he is awaiting a stable release of +something new (Test2) to completely rewrite it in a sane way. + +Still broken as of version: 0.32 + +=item Test::More::Prefix + +The current version, 0.005 is broken. A patch has been applied in git, and +released in 0.006, but a version issue with 0.006 prevents its installation. + +Still broken as of version: 0.005 +Potentially fixed in version: 0.006 (not installable) + +=item Net::BitTorrent + +The tests for this module directly access L hash keys. Most, if +not all of these hash keys have public API methods that could be used instead +to avoid the problem. + +Still broken in version: 0.052 + +=item Test::Group + +It monkeypatches Test::Builder, and calls it "black magic" in the code. + +Still broken as of version: 0.20 + +=item Test::Flatten + +This modifies the Test::Builder internals in many ways. A better was to +accomplish the goal of this module is to write your own subtest function. + +Still broken as of version: 0.11 + +=item Log::Dispatch::Config::TestLog + +Modifies Test::Builder internals. + +Still broken as of version: 0.02 + +=item Test::Able + +Modifies Test::Builder internals. + +Still broken as of version: 0.11 + +=back + +=head1 MAKE ASSERTIONS -> SEND EVENTS + +=head2 LEGACY + + use Test::Builder; + + # A majority of tools out there do this: + # my $TB = Test::Builder->new; + # This works, but has always been wrong, forcing Test::Builder to implement + # subtests as a horrific hack. It also causes problems for tools that try + # to replace the singleton (also discouraged). + + sub my_ok($;$) { + my ($bool, $name) = @_; + my $TB = Test::Builder->new; + $TB->ok($bool, $name); + } + + sub my_diag($) { + my ($msg) = @_; + my $TB = Test::Builder->new; + $TB->diag($msg); + } + +=head2 TEST2 + + use Test2::API qw/context/; + + sub my_ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; + } + + sub my_diag($) { + my ($msg) = @_; + my $ctx = context(); + $ctx->diag($msg); + $ctx->release; + } + +The context object has API compatible implementations of the following methods: + +=over 4 + +=item ok($bool, $name) + +=item diag(@messages) + +=item note(@messages) + +=item subtest($name, $code) + +=back + +If you are looking for helpers with C, C, and others, see +L. + +=head1 WRAP EXISTING TOOLS + +=head2 LEGACY + + use Test::More; + + sub exclusive_ok { + my ($bool1, $bool2, $name) = @_; + + # Ensure errors are reported 1 level higher + local $Test::Builder::Level = $Test::Builder::Level + 1; + + $ok = $bool1 || $bool2; + $ok &&= !($bool1 && $bool2); + ok($ok, $name); + + return $bool; + } + +Every single tool in the chain from this, to C, to anything C calls +needs to increment the C<$Level> variable. When an error occurs Test::Builder +will do a trace to the stack frame determined by C<$Level>, and report that +file+line as the one where the error occurred. If you or any other tool you use +forgets to set C<$Level> then errors will be reported to the wrong place. + +=head2 TEST2 + + use Test::More; + + sub exclusive_ok { + my ($bool1, $bool2, $name) = @_; + + # Grab and store the context, even if you do not need to use it + # directly. + my $ctx = context(); + + $ok = $bool1 || $bool2; + $ok &&= !($bool1 && $bool2); + ok($ok, $name); + + $ctx->release; + return $bool; + } + +Instead of using C<$Level> to perform a backtrace, Test2 uses a context +object. In this sample you create a context object and store it. This locks the +context (errors report 1 level up from here) for all wrapped tools to find. You +do not need to use the context object, but you do need to store it in a +variable. Once the sub ends the C<$ctx> variable is destroyed which lets future +tools find their own. + +=head1 USING UTF8 + +=head2 LEGACY + + # Set the mode BEFORE anything loads Test::Builder + use open ':std', ':encoding(utf8)'; + use Test::More; + +Or + + # Modify the filehandles + my $builder = Test::More->builder; + binmode $builder->output, ":encoding(utf8)"; + binmode $builder->failure_output, ":encoding(utf8)"; + binmode $builder->todo_output, ":encoding(utf8)"; + +=head2 TEST2 + + use Test2::API qw/test2_stack/; + + test2_stack->top->format->encoding('utf8'); + +Though a much better way is to use the L plugin, which is +part of L. + +=head1 AUTHORS, CONTRIBUTORS AND REVIEWERS + +The following people have all contributed to this document in some way, even if +only for review. + +=over 4 + +=item Chad Granum (EXODIST) Eexodist@cpan.orgE + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Util.pm b/dist/Test-Simple/lib/Test2/Util.pm new file mode 100644 index 00000000000..f2c5a4de546 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Util.pm @@ -0,0 +1,258 @@ +package Test2::Util; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Config qw/%Config/; + +our @EXPORT_OK = qw{ + try + + pkg_to_file + + get_tid USE_THREADS + CAN_THREAD + CAN_REALLY_FORK + CAN_FORK + + IS_WIN32 + + ipc_separator +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +BEGIN { + *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; +} + +sub _can_thread { + return 0 unless $] >= 5.008001; + return 0 unless $Config{'useithreads'}; + + # Threads are broken on perl 5.10.0 built with gcc 4.8+ + if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { + my @parts = split /\./, $Config{'gccversion'}; + return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); + } + + # Change to a version check if this ever changes + return 0 if $INC{'Devel/Cover.pm'}; + return 1; +} + +sub _can_fork { + return 1 if $Config{d_fork}; + return 0 unless IS_WIN32 || $^O eq 'NetWare'; + return 0 unless $Config{useithreads}; + return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; + + return _can_thread(); +} + +BEGIN { + no warnings 'once'; + *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; +} +my $can_fork; +sub CAN_FORK () { + return $can_fork + if defined $can_fork; + $can_fork = !!_can_fork(); + no warnings 'redefine'; + *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; + $can_fork; +} +my $can_really_fork; +sub CAN_REALLY_FORK () { + return $can_really_fork + if defined $can_really_fork; + $can_really_fork = !!$Config{d_fork}; + no warnings 'redefine'; + *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; + $can_really_fork; +} + +sub _manual_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + my $die = delete $SIG{__DIE__}; + + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__}; + + return (!defined($err), $err); +} + +sub _local_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + no warnings; + local $SIG{__DIE__}; + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + return (!defined($err), $err); +} + +# Older versions of perl have a nasty bug on win32 when localizing a variable +# before forking or starting a new thread. So for those systems we use the +# non-local form. When possible though we use the faster 'local' form. +BEGIN { + if (IS_WIN32 && $] < 5.020002) { + *try = \&_manual_try; + } + else { + *try = \&_local_try; + } +} + +BEGIN { + if (CAN_THREAD) { + if ($INC{'threads.pm'}) { + # Threads are already loaded, so we do not need to check if they + # are loaded each time + *USE_THREADS = sub() { 1 }; + *get_tid = sub() { threads->tid() }; + } + else { + # :-( Need to check each time to see if they have been loaded. + *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 }; + *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 }; + } + } + else { + # No threads, not now, not ever! + *USE_THREADS = sub() { 0 }; + *get_tid = sub() { 0 }; + } +} + +sub pkg_to_file { + my $pkg = shift; + my $file = $pkg; + $file =~ s{(::|')}{/}g; + $file .= '.pm'; + return $file; +} + +sub ipc_separator() { "~" } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util - Tools used by Test2 and friends. + +=head1 DESCRIPTION + +Collection of tools used by L and friends. + +=head1 EXPORTS + +All exports are optional. You must specify subs to import. + +=over 4 + +=item ($success, $error) = try { ... } + +Eval the codeblock, return success or failure, and 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 CAN_FORK + +True if this system is capable of true or pseudo-fork. + +=item CAN_REALLY_FORK + +True if the system can really fork. This will be false for systems where fork +is emulated. + +=item CAN_THREAD + +True if this system is capable of using threads. + +=item USE_THREADS + +Returns true if threads are enabled, false if they are not. + +=item get_tid + +This will return the id of the current thread when threads are enabled, +otherwise it returns 0. + +=item my $file = pkg_to_file($package) + +Convert a package name to a filename. + +=back + +=head1 NOTES && CAVEATS + +=over 4 + +=item 5.10.0 + +Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a +segfault whenever a new thread is launched. Test2 will attempt to detect +this, and note that the system is not capable of forking when it is detected. + +=item Devel::Cover + +Devel::Cover does not support threads. CAN_THREAD will return false if +Devel::Cover is loaded before the check is first run. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Util/ExternalMeta.pm b/dist/Test-Simple/lib/Test2/Util/ExternalMeta.pm new file mode 100644 index 00000000000..40d893fe085 --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Util/ExternalMeta.pm @@ -0,0 +1,182 @@ +package Test2::Util::ExternalMeta; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Carp qw/croak/; + +sub META_KEY() { '_meta' } + +our @EXPORT = qw/meta set_meta get_meta delete_meta/; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub set_meta { + my $self = shift; + my ($key, $value) = @_; + + validate_key($key); + + $self->{+META_KEY} ||= {}; + $self->{+META_KEY}->{$key} = $value; +} + +sub get_meta { + my $self = shift; + my ($key) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY} or return undef; + return $meta->{$key}; +} + +sub delete_meta { + my $self = shift; + my ($key) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY} or return undef; + delete $meta->{$key}; +} + +sub meta { + my $self = shift; + my ($key, $default) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY}; + return undef unless $meta || defined($default); + + unless($meta) { + $meta = {}; + $self->{+META_KEY} = $meta; + } + + $meta->{$key} = $default + if defined($default) && !defined($meta->{$key}); + + return $meta->{$key}; +} + +sub validate_key { + my $key = shift; + + return if $key && !ref($key); + + my $render_key = defined($key) ? "'$key'" : 'undef'; + croak "Invalid META key: $render_key, keys must be true, and may not be references"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data +to your instances. + +=head1 DESCRIPTION + +This package lets you define a clear, and consistent way to allow third party +tools to attach meta-data to your instances. If your object consumes this +package, and imports its methods, then third party meta-data has a safe place +to live. + +=head1 SYNOPSIS + + package My::Object; + use strict; + use warnings; + + use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; + + ... + +Now to use it: + + my $inst = My::Object->new; + + $inst->set_meta(foo => 'bar'); + my $val = $inst->get_meta('foo'); + +=head1 WHERE IS THE DATA STORED? + +This package assumes your instances are blessed hashrefs, it will not work if +that is not true. It will store all meta-data in the C<_meta> key on your +objects hash. If your object makes use of the C<_meta> key in its underlying +hash, then there is a conflict and you cannot use this package. + +=head1 EXPORTS + +=over 4 + +=item $val = $obj->meta($key) + +=item $val = $obj->meta($key, $default) + +This will get the value for a specified meta C<$key>. Normally this will return +C when there is no value for the C<$key>, however you can specify a +C<$default> value to set when no value is already set. + +=item $val = $obj->get_meta($key) + +This will get the value for a specified meta C<$key>. This does not have the +C<$default> overhead that C does. + +=item $val = $obj->delete_meta($key) + +This will remove the value of a specified meta C<$key>. The old C<$val> will be +returned. + +=item $obj->set_meta($key, $val) + +Set the value of a specified meta C<$key>. + +=back + +=head1 META-KEY RESTRICTIONS + +Meta keys must be defined, and must be true when used as a boolean. Keys may +not be references. You are free to stringify a reference C<"$ref"> for use as a +key, but this package will not stringify it for you. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Util/HashBase.pm b/dist/Test-Simple/lib/Test2/Util/HashBase.pm new file mode 100644 index 00000000000..76041efe5ee --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Util/HashBase.pm @@ -0,0 +1,289 @@ +package Test2::Util::HashBase; +use strict; +use warnings; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Util::HashBase::VERSION = '0.002'; + *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %STRIP = ( + '^' => 1, + '-' => 1, +); + +sub import { + my $class = shift; + my $into = caller; + + my $isa = _isa($into); + my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {}; + my %subs = ( + ($into->can('new') ? () : (new => \&_new)), + (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ( + map { + my $p = substr($_, 0, 1); + my $x = $_; + substr($x, 0, 1) = '' if $STRIP{$p}; + my ($sub, $attr) = (uc $x, $x); + $sub => ($attr_subs->{$sub} = sub() { $attr }), + $attr => sub { $_[0]->{$attr} }, + $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") }) + : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] }) + : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }), + } @_ + ), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub _new { + my ($class, %params) = @_; + my $self = bless \%params, $class; + $self->init if $self->can('init'); + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Util::HashBase 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; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Util::HashBase qw/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(foo => 'MyFoo', bar => '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'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + $one->{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. 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 key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L. This file was generated using +the +C +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(@VALUES) + +Create a new instance using key/value pairs. + +HashBase will not export C if there is already a C method in your +packages inheritance chain. + +B you just have to +declare it before loading L. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +=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 Test2::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=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, returns the field C's key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 SOURCE + +The source code repository for HashBase can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/Test2/Util/Trace.pm b/dist/Test-Simple/lib/Test2/Util/Trace.pm new file mode 100644 index 00000000000..b0b22dd2e3a --- /dev/null +++ b/dist/Test-Simple/lib/Test2/Util/Trace.pm @@ -0,0 +1,209 @@ +package Test2::Util::Trace; +use strict; +use warnings; + +our $VERSION = '1.302075'; + + +use Test2::Util qw/get_tid pkg_to_file/; + +use Carp qw/confess/; + +use Test2::Util::HashBase qw{frame detail pid tid cid}; + +my $CID = 1; +sub init { + confess "The 'frame' attribute is required" + unless $_[0]->{+FRAME}; + + $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; + $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; + $_[0]->{+CID} = 'T' . $CID++ unless defined $_[0]->{+CID}; +} + +sub snapshot { bless {%{$_[0]}}, __PACKAGE__ }; + +sub signature { + my $self = shift; + + # Signature is only valid if all of these fields are defined, there is no + # signature if any is missing. '0' is ok, but '' is not. + return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } ( + $self->{+CID}, + $self->{+PID}, + $self->{+TID}, + $self->{+FRAME}->[1], + $self->{+FRAME}->[2], + ); +} + +sub debug { + my $self = shift; + return $self->{+DETAIL} if $self->{+DETAIL}; + my ($pkg, $file, $line) = $self->call; + return "at $file line $line"; +} + +sub alert { + my $self = shift; + my ($msg) = @_; + warn $msg . ' ' . $self->debug . ".\n"; +} + +sub throw { + my $self = shift; + my ($msg) = @_; + die $msg . ' ' . $self->debug . ".\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 from_json { + my $class = shift; + my %p = @_; + + my $trace_pkg = delete $p{__PACKAGE__}; + require(pkg_to_file($trace_pkg)); + + return $trace_pkg->new(%p); +} + +sub TO_JSON { + my $self = shift; + return {%$self, __PACKAGE__ => ref $self}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Trace - Debug information for events + +=head1 DESCRIPTION + +The L object, as well as all L types need to +have access to information about where they were created. This object +represents that information. + +=head1 SYNOPSIS + + use Test2::Util::Trace; + + my $trace = Test2::Util::Trace->new( + frame => [$package, $file, $line, $subname], + ); + +=head1 METHODS + +=over 4 + +=item $trace->set_detail($msg) + +=item $msg = $trace->detail + +Used to get/set a custom trace message that will be used INSTEAD of +C<< at line >> when calling C<< $trace->debug >>. + +=item $str = $trace->debug + +Typically returns the string C<< at line >>. If C is set +then its value will be returned instead. + +=item $trace->alert($MESSAGE) + +This issues a warning at the frame (filename and line number where +errors should be reported). + +=item $trace->throw($MESSAGE) + +This throws an exception at the frame (filename and line number where +errors should be reported). + +=item $frame = $trace->frame() + +Get the call frame arrayref. + +=item ($package, $file, $line, $subname) = $trace->call() + +Get the caller details for the debug-info. This is where errors should be +reported. + +=item $pkg = $trace->package + +Get the debug-info package. + +=item $file = $trace->file + +Get the debug-info filename. + +=item $line = $trace->line + +Get the debug-info line number. + +=item $subname = $trace->subname + +Get the debug-info subroutine name. + +=item $sig = trace->signature + +Get a signature string that identifies this trace. This is used to check if +multiple events are related. The Trace includes pid, tid, file, line number, +and the cid which is C<'C\d+'> for traces created by a context, or C<'T\d+'> +for traces created by C. + +=item $hashref = $t->TO_JSON + +This returns a hashref suitable for passing to the C<< +Test2::Util::Trace->from_json >> constructor. It is intended for use with the +L family of modules, which will look for a C method when +C is true. + +=item $t = Test2::Util::Trace->from_json(%$hashref) + +Given the hash of data returned by C<< $t->TO_JSON >>, this method returns a +new trace object of the appropriate subclass. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +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/dist/Test-Simple/lib/ok.pm b/dist/Test-Simple/lib/ok.pm index 02726ac9641..b7d617b78b9 100644 --- a/dist/Test-Simple/lib/ok.pm +++ b/dist/Test-Simple/lib/ok.pm @@ -1,5 +1,5 @@ package ok; -$ok::VERSION = '0.16'; +our $VERSION = '1.302075'; use strict; use Test::More (); @@ -20,6 +20,8 @@ sub import { __END__ +=encoding UTF-8 + =head1 NAME ok - Alternative to Test::More::use_ok diff --git a/dist/Test-Simple/t/00-report.t b/dist/Test-Simple/t/00-report.t new file mode 100644 index 00000000000..65d8b93f1d4 --- /dev/null +++ b/dist/Test-Simple/t/00-report.t @@ -0,0 +1,75 @@ +use strict; +use warnings; + +my $exit = 0; +END{ $? = $exit } + +use File::Spec; + +my ($stderr, $stdout); +BEGIN { + $exit = 0; + END{ $? = $exit } + print STDOUT "ok 1\n"; + print STDOUT "1..1\n"; + + open($stdout, '>&', *STDOUT) or die "Could not clone STDOUT"; + open($stderr, '>&', *STDERR) or die "Could not clone STDERR"; + + close(STDOUT) or die "Could not close STDOUT"; + unless(close(STDERR)) { + print $stderr "Could not close STDERR\n"; + $exit = 255; + exit $exit; + } + + open(STDOUT, '>', File::Spec->devnull); + open(STDERR, '>', File::Spec->devnull); +} + +use Test2::Util qw/CAN_FORK CAN_REALLY_FORK CAN_THREAD/; +use Test2::API; + +sub diag { + print $stderr "\n" unless @_; + print $stderr "# $_\n" for @_; +} + +diag; +diag "DIAGNOSTICS INFO IN CASE OF FAILURE:"; +diag; +diag "Perl: $]"; + +diag; +diag "CAPABILITIES:"; +diag 'CAN_FORK ' . (CAN_FORK ? 'Yes' : 'No'); +diag 'CAN_REALLY_FORK ' . (CAN_REALLY_FORK ? 'Yes' : 'No'); +diag 'CAN_THREAD ' . (CAN_THREAD ? 'Yes' : 'No'); + +diag; +diag "DEPENDENCIES:"; + +my @depends = sort qw{ + Carp + File::Spec + File::Temp + PerlIO + Scalar::Util + Storable + Test2 + overload + threads + utf8 +}; + +my %deps; +my $len = 0; +for my $dep (@depends) { + my $l = length($dep); + $len = $l if $l > $len; + $deps{$dep} = eval "require $dep; $dep->VERSION" || "N/A"; +} + +diag sprintf("%-${len}s %s", $_, $deps{$_}) for @depends; + +END{ $? = $exit } diff --git a/dist/Test-Simple/t/Builder/fork_with_new_stdout.t b/dist/Test-Simple/t/Builder/fork_with_new_stdout.t deleted file mode 100644 index e38c1d08cbc..00000000000 --- a/dist/Test-Simple/t/Builder/fork_with_new_stdout.t +++ /dev/null @@ -1,54 +0,0 @@ -#!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/dist/Test-Simple/t/00test_harness_check.t b/dist/Test-Simple/t/Legacy/00test_harness_check.t similarity index 100% rename from dist/Test-Simple/t/00test_harness_check.t rename to dist/Test-Simple/t/Legacy/00test_harness_check.t diff --git a/dist/Test-Simple/t/01-basic.t b/dist/Test-Simple/t/Legacy/01-basic.t similarity index 100% rename from dist/Test-Simple/t/01-basic.t rename to dist/Test-Simple/t/Legacy/01-basic.t diff --git a/dist/Test-Simple/t/478-cmp_ok_hash.t b/dist/Test-Simple/t/Legacy/478-cmp_ok_hash.t similarity index 100% rename from dist/Test-Simple/t/478-cmp_ok_hash.t rename to dist/Test-Simple/t/Legacy/478-cmp_ok_hash.t diff --git a/dist/Test-Simple/t/BEGIN_require_ok.t b/dist/Test-Simple/t/Legacy/BEGIN_require_ok.t similarity index 88% rename from dist/Test-Simple/t/BEGIN_require_ok.t rename to dist/Test-Simple/t/Legacy/BEGIN_require_ok.t index 0a732640654..733d0bb861c 100644 --- a/dist/Test-Simple/t/BEGIN_require_ok.t +++ b/dist/Test-Simple/t/Legacy/BEGIN_require_ok.t @@ -7,7 +7,8 @@ use strict; BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/BEGIN_use_ok.t b/dist/Test-Simple/t/Legacy/BEGIN_use_ok.t similarity index 86% rename from dist/Test-Simple/t/BEGIN_use_ok.t rename to dist/Test-Simple/t/Legacy/BEGIN_use_ok.t index d0d8e1b5a83..476badf7a29 100644 --- a/dist/Test-Simple/t/BEGIN_use_ok.t +++ b/dist/Test-Simple/t/Legacy/BEGIN_use_ok.t @@ -6,7 +6,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/Legacy/Bugs/600.t b/dist/Test-Simple/t/Legacy/Bugs/600.t new file mode 100644 index 00000000000..ce47e40aa76 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/Bugs/600.t @@ -0,0 +1,16 @@ +use Test2::API qw/intercept/; +use Test::More; + +my $TEST = Test::Builder->new(); + +sub fake { + $TEST->use_numbers(0); + $TEST->no_ending(1); + $TEST->done_testing(1); # a computed number of tests from its deferred magic +} + +my $events = intercept { fake() }; +is(@$events, 1, "only 1 event"); +is($events->[0]->max, 1, "Plan set to 1, not 0"); + +done_testing; diff --git a/dist/Test-Simple/t/Legacy/Bugs/629.t b/dist/Test-Simple/t/Legacy/Bugs/629.t new file mode 100644 index 00000000000..ba5edf8512f --- /dev/null +++ b/dist/Test-Simple/t/Legacy/Bugs/629.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +use Test::More; +use Test2::API qw/intercept/; + +my @warnings; + +intercept { + SKIP: { + local $SIG{__WARN__} = sub { @warnings = @_ }; + skip 'Skipping this test' if 1; + my $var = 'abc'; + is $var, 'abc'; + } +}; + +ok(!@warnings, "did not warn when waiting for done_testing"); + +intercept { + SKIP: { + local $SIG{__WARN__} = sub { @warnings = @_ }; + plan 'no_plan'; + skip 'Skipping this test' if 1; + my $var = 'abc'; + is $var, 'abc'; + } +}; + +ok(!@warnings, "did not warn with 'no_plan'"); + +intercept { + SKIP: { + local $SIG{__WARN__} = sub { @warnings = @_ }; + plan tests => 1; + skip 'Skipping this test' if 1; + my $var = 'abc'; + is $var, 'abc'; + } +}; + +is(@warnings, 1, "warned with static plan"); +like( + $warnings[0], + qr/skip\(\) needs to know \$how_many tests are in the block/, + "Got expected warning" +); + +done_testing; diff --git a/dist/Test-Simple/t/Builder/Builder.t b/dist/Test-Simple/t/Legacy/Builder/Builder.t similarity index 100% rename from dist/Test-Simple/t/Builder/Builder.t rename to dist/Test-Simple/t/Legacy/Builder/Builder.t diff --git a/dist/Test-Simple/t/Builder/carp.t b/dist/Test-Simple/t/Legacy/Builder/carp.t similarity index 100% rename from dist/Test-Simple/t/Builder/carp.t rename to dist/Test-Simple/t/Legacy/Builder/carp.t diff --git a/dist/Test-Simple/t/Builder/create.t b/dist/Test-Simple/t/Legacy/Builder/create.t similarity index 100% rename from dist/Test-Simple/t/Builder/create.t rename to dist/Test-Simple/t/Legacy/Builder/create.t diff --git a/dist/Test-Simple/t/Builder/current_test.t b/dist/Test-Simple/t/Legacy/Builder/current_test.t similarity index 100% rename from dist/Test-Simple/t/Builder/current_test.t rename to dist/Test-Simple/t/Legacy/Builder/current_test.t diff --git a/dist/Test-Simple/t/Builder/current_test_without_plan.t b/dist/Test-Simple/t/Legacy/Builder/current_test_without_plan.t similarity index 100% rename from dist/Test-Simple/t/Builder/current_test_without_plan.t rename to dist/Test-Simple/t/Legacy/Builder/current_test_without_plan.t diff --git a/dist/Test-Simple/t/Builder/details.t b/dist/Test-Simple/t/Legacy/Builder/details.t similarity index 98% rename from dist/Test-Simple/t/Builder/details.t rename to dist/Test-Simple/t/Legacy/Builder/details.t index a13641cae62..05d4828b4d9 100644 --- a/dist/Test-Simple/t/Builder/details.t +++ b/dist/Test-Simple/t/Legacy/Builder/details.t @@ -40,7 +40,7 @@ SKIP: { } push @Expected_Details, { 'ok' => 1, actual_ok => 1, - name => undef, + name => '', type => 'skip', reason => 'just testing skip', }; diff --git a/dist/Test-Simple/t/Builder/done_testing.t b/dist/Test-Simple/t/Legacy/Builder/done_testing.t similarity index 100% rename from dist/Test-Simple/t/Builder/done_testing.t rename to dist/Test-Simple/t/Legacy/Builder/done_testing.t diff --git a/dist/Test-Simple/t/Builder/done_testing_double.t b/dist/Test-Simple/t/Legacy/Builder/done_testing_double.t similarity index 100% rename from dist/Test-Simple/t/Builder/done_testing_double.t rename to dist/Test-Simple/t/Legacy/Builder/done_testing_double.t diff --git a/dist/Test-Simple/t/Builder/done_testing_plan_mismatch.t b/dist/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t similarity index 100% rename from dist/Test-Simple/t/Builder/done_testing_plan_mismatch.t rename to dist/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t diff --git a/dist/Test-Simple/t/Builder/done_testing_with_no_plan.t b/dist/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t similarity index 100% rename from dist/Test-Simple/t/Builder/done_testing_with_no_plan.t rename to dist/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t diff --git a/dist/Test-Simple/t/Builder/done_testing_with_number.t b/dist/Test-Simple/t/Legacy/Builder/done_testing_with_number.t similarity index 100% rename from dist/Test-Simple/t/Builder/done_testing_with_number.t rename to dist/Test-Simple/t/Legacy/Builder/done_testing_with_number.t diff --git a/dist/Test-Simple/t/Builder/done_testing_with_plan.t b/dist/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t similarity index 100% rename from dist/Test-Simple/t/Builder/done_testing_with_plan.t rename to dist/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t diff --git a/dist/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t b/dist/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t new file mode 100644 index 00000000000..594402ee7f5 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t @@ -0,0 +1,51 @@ +#!perl -w +use strict; +use warnings; + +use Test2::Util qw/CAN_FORK/; +BEGIN { + unless(CAN_FORK) { + require Test::More; + Test::More->import(skip_all => "fork is not supported"); + } +} + +use IO::Pipe; +use Test::Builder; +use Config; + +my $b = Test::Builder->new; +$b->reset; + +$b->plan('tests' => 2); + +my $pipe = IO::Pipe->new; +if ( my $pid = fork ) { + $pipe->reader; + my ($one, $two) = <$pipe>; + $b->like($one, qr/ok 1/, "ok 1 from child"); + $b->like($two, qr/1\.\.1/, "1..1 from child"); + waitpid($pid, 0); +} +else { + $pipe->writer; + $b->reset; + $b->no_plan; + $b->output($pipe); + $b->ok(1); + $b->done_testing; +} + + +=pod +#actual +1..2 +ok 1 +1..1 +ok 1 +ok 2 +#expected +1..2 +ok 1 +ok 2 +=cut diff --git a/dist/Test-Simple/t/Builder/has_plan.t b/dist/Test-Simple/t/Legacy/Builder/has_plan.t similarity index 100% rename from dist/Test-Simple/t/Builder/has_plan.t rename to dist/Test-Simple/t/Legacy/Builder/has_plan.t diff --git a/dist/Test-Simple/t/Builder/has_plan2.t b/dist/Test-Simple/t/Legacy/Builder/has_plan2.t similarity index 100% rename from dist/Test-Simple/t/Builder/has_plan2.t rename to dist/Test-Simple/t/Legacy/Builder/has_plan2.t diff --git a/dist/Test-Simple/t/Builder/is_fh.t b/dist/Test-Simple/t/Legacy/Builder/is_fh.t similarity index 100% rename from dist/Test-Simple/t/Builder/is_fh.t rename to dist/Test-Simple/t/Legacy/Builder/is_fh.t diff --git a/dist/Test-Simple/t/Builder/is_passing.t b/dist/Test-Simple/t/Legacy/Builder/is_passing.t similarity index 100% rename from dist/Test-Simple/t/Builder/is_passing.t rename to dist/Test-Simple/t/Legacy/Builder/is_passing.t diff --git a/dist/Test-Simple/t/Builder/maybe_regex.t b/dist/Test-Simple/t/Legacy/Builder/maybe_regex.t similarity index 100% rename from dist/Test-Simple/t/Builder/maybe_regex.t rename to dist/Test-Simple/t/Legacy/Builder/maybe_regex.t diff --git a/dist/Test-Simple/t/Builder/no_diag.t b/dist/Test-Simple/t/Legacy/Builder/no_diag.t similarity index 100% rename from dist/Test-Simple/t/Builder/no_diag.t rename to dist/Test-Simple/t/Legacy/Builder/no_diag.t diff --git a/dist/Test-Simple/t/Builder/no_ending.t b/dist/Test-Simple/t/Legacy/Builder/no_ending.t similarity index 100% rename from dist/Test-Simple/t/Builder/no_ending.t rename to dist/Test-Simple/t/Legacy/Builder/no_ending.t diff --git a/dist/Test-Simple/t/Builder/no_header.t b/dist/Test-Simple/t/Legacy/Builder/no_header.t similarity index 100% rename from dist/Test-Simple/t/Builder/no_header.t rename to dist/Test-Simple/t/Legacy/Builder/no_header.t diff --git a/dist/Test-Simple/t/Builder/no_plan_at_all.t b/dist/Test-Simple/t/Legacy/Builder/no_plan_at_all.t similarity index 100% rename from dist/Test-Simple/t/Builder/no_plan_at_all.t rename to dist/Test-Simple/t/Legacy/Builder/no_plan_at_all.t diff --git a/dist/Test-Simple/t/Builder/ok_obj.t b/dist/Test-Simple/t/Legacy/Builder/ok_obj.t similarity index 100% rename from dist/Test-Simple/t/Builder/ok_obj.t rename to dist/Test-Simple/t/Legacy/Builder/ok_obj.t diff --git a/dist/Test-Simple/t/Builder/output.t b/dist/Test-Simple/t/Legacy/Builder/output.t similarity index 100% rename from dist/Test-Simple/t/Builder/output.t rename to dist/Test-Simple/t/Legacy/Builder/output.t diff --git a/dist/Test-Simple/t/Builder/reset.t b/dist/Test-Simple/t/Legacy/Builder/reset.t similarity index 100% rename from dist/Test-Simple/t/Builder/reset.t rename to dist/Test-Simple/t/Legacy/Builder/reset.t diff --git a/dist/Test-Simple/t/Builder/reset_outputs.t b/dist/Test-Simple/t/Legacy/Builder/reset_outputs.t similarity index 100% rename from dist/Test-Simple/t/Builder/reset_outputs.t rename to dist/Test-Simple/t/Legacy/Builder/reset_outputs.t diff --git a/dist/Test-Simple/t/Builder/try.t b/dist/Test-Simple/t/Legacy/Builder/try.t similarity index 100% rename from dist/Test-Simple/t/Builder/try.t rename to dist/Test-Simple/t/Legacy/Builder/try.t diff --git a/dist/Test-Simple/t/More.t b/dist/Test-Simple/t/Legacy/More.t similarity index 97% rename from dist/Test-Simple/t/More.t rename to dist/Test-Simple/t/Legacy/More.t index 3a79ba46820..ce535e26d99 100644 --- a/dist/Test-Simple/t/More.t +++ b/dist/Test-Simple/t/Legacy/More.t @@ -2,12 +2,13 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = qw(../../lib t/lib); + chdir 't'; + @INC = qw(../lib ../lib/Test/Simple/t/lib); } } use lib 't/lib'; -use Test::More tests => 53; +use Test::More tests => 54; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; @@ -23,8 +24,7 @@ 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'); -# now illegal -#isn't("foo", "bar", 'foo isn\'t bar'); +isn't("foo", "bar", 'foo isn\'t bar'); #'# like("fooble", '/^foo/', 'foo is like fooble'); diff --git a/dist/Test-Simple/t/Legacy/Regression/637.t b/dist/Test-Simple/t/Legacy/Regression/637.t new file mode 100644 index 00000000000..c3aaf44c79f --- /dev/null +++ b/dist/Test-Simple/t/Legacy/Regression/637.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test2::Util qw/CAN_THREAD/; +BEGIN { + unless(CAN_THREAD) { + print "1..0 # Skip threads are not supported.\n"; + exit 0; + } +} + +BEGIN { + unless ( $ENV{AUTHOR_TESTING} ) { + print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; + exit 0; + } +} + +use Test2::IPC; +use threads; +use Test::More; + +ok 1 for (1 .. 2); + +# used to reset the counter after thread finishes +my $ct_num = Test::More->builder->current_test; + +my $subtest_out = async { + my $out = ''; + + #simulate a subtest to not confuse the parent TAP emission + my $tb = Test::More->builder; + $tb->reset; + for (qw/output failure_output todo_output/) { + close $tb->$_; + open($tb->$_, '>', \$out); + } + + ok 1 for (1 .. 3); + + done_testing; + + close $tb->$_ for (qw/output failure_output todo_output/); + + $out; +} +->join; + +$subtest_out =~ s/^/ /gm; +print $subtest_out; + +# reset as if the thread never "said" anything +Test::More->builder->current_test($ct_num); + +ok 1 for (1 .. 4); + +done_testing; diff --git a/dist/Test-Simple/t/Legacy/Regression/683_thread_todo.t b/dist/Test-Simple/t/Legacy/Regression/683_thread_todo.t new file mode 100644 index 00000000000..c5eb7cb629f --- /dev/null +++ b/dist/Test-Simple/t/Legacy/Regression/683_thread_todo.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test2::Util qw/CAN_THREAD/; +BEGIN { + unless(CAN_THREAD) { + require Test::More; + Test::More->import(skip_all => "threads are not supported"); + } +} + +use threads; +use Test::More; + +my $t = threads->create( + sub { + local $TODO = "Some good reason"; + + fail "Crap"; + + 42; + } +); + +is( + $t->join, + 42, + "Thread exitted successfully" +); + +done_testing; diff --git a/dist/Test-Simple/t/Legacy/Regression/6_cmp_ok.t b/dist/Test-Simple/t/Legacy/Regression/6_cmp_ok.t new file mode 100644 index 00000000000..05cfcba9a40 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/Regression/6_cmp_ok.t @@ -0,0 +1,17 @@ +use Test::More; + +use Test2::API qw/intercept/; + +my $events = intercept { + local $SIG{__WARN__} = sub { 1 }; + my $foo = undef; + cmp_ok($foo, "ne", ""); +}; + +is($events->[-1]->message, <(); + return $warn || ""; +} + +my $file = __FILE__; +my $line = __LINE__ + 2; +like( + capture { use_ok 'MyWarner' }, + qr/^Deprected! run for your lives! at \Q$file\E line $line/, + "Got the warning" +); + +ok(!capture { no warnings 'deprecated'; use_ok 'MyWarner' }, "No warning"); + +done_testing; diff --git a/dist/Test-Simple/t/Simple/load.t b/dist/Test-Simple/t/Legacy/Simple/load.t similarity index 100% rename from dist/Test-Simple/t/Simple/load.t rename to dist/Test-Simple/t/Legacy/Simple/load.t diff --git a/dist/Test-Simple/t/Legacy/Test2/Subtest.t b/dist/Test-Simple/t/Legacy/Test2/Subtest.t new file mode 100644 index 00000000000..31afb0ac8c2 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/Test2/Subtest.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; +use Test2::API qw/intercept/; + +my $res = intercept { + subtest foo => sub { + ok(1, "check"); + }; +}; + +is(@$res, 2, "2 results"); + +isa_ok($res->[0], 'Test2::Event::Note'); +is($res->[0]->message, 'Subtest: foo', "got subtest note"); + +isa_ok($res->[1], 'Test2::Event::Subtest'); +ok($res->[1]->pass, "subtest passed"); + +my $subs = $res->[1]->subevents; +is(@$subs, 2, "got all subevents"); + +isa_ok($subs->[0], 'Test2::Event::Ok'); +is($subs->[0]->pass, 1, "subtest ok passed"); +is($subs->[0]->name, 'check', "subtest ok name"); + +isa_ok($subs->[1], 'Test2::Event::Plan'); +is($subs->[1]->max, 1, "subtest plan is 1"); + +done_testing; diff --git a/dist/Test-Simple/t/Tester/tbt_01basic.t b/dist/Test-Simple/t/Legacy/Tester/tbt_01basic.t similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_01basic.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_01basic.t diff --git a/dist/Test-Simple/t/Tester/tbt_02fhrestore.t b/dist/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_02fhrestore.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t diff --git a/dist/Test-Simple/t/Tester/tbt_03die.t b/dist/Test-Simple/t/Legacy/Tester/tbt_03die.t similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_03die.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_03die.t diff --git a/dist/Test-Simple/t/Tester/tbt_04line_num.t b/dist/Test-Simple/t/Legacy/Tester/tbt_04line_num.t similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_04line_num.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_04line_num.t diff --git a/dist/Test-Simple/t/Tester/tbt_05faildiag.t b/dist/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_05faildiag.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t diff --git a/dist/Test-Simple/t/Tester/tbt_06errormess.t b/dist/Test-Simple/t/Legacy/Tester/tbt_06errormess.t similarity index 97% rename from dist/Test-Simple/t/Tester/tbt_06errormess.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_06errormess.t index b02b6172938..ec3abc63ea8 100644 --- a/dist/Test-Simple/t/Tester/tbt_06errormess.t +++ b/dist/Test-Simple/t/Legacy/Tester/tbt_06errormess.t @@ -9,7 +9,7 @@ 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 +# annoying but can't be avoided. And onward with the cut and paste # My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING diff --git a/dist/Test-Simple/t/Tester/tbt_07args.t b/dist/Test-Simple/t/Legacy/Tester/tbt_07args.t similarity index 98% rename from dist/Test-Simple/t/Tester/tbt_07args.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_07args.t index 9542d755f4d..9b631ab470c 100644 --- a/dist/Test-Simple/t/Tester/tbt_07args.t +++ b/dist/Test-Simple/t/Legacy/Tester/tbt_07args.t @@ -9,7 +9,7 @@ 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 +# annoying but can't be avoided. And onward with the cut and paste # My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING diff --git a/dist/Test-Simple/t/Tester/tbt_08subtest.t b/dist/Test-Simple/t/Legacy/Tester/tbt_08subtest.t similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_08subtest.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_08subtest.t diff --git a/dist/Test-Simple/t/Tester/tbt_09do.t b/dist/Test-Simple/t/Legacy/Tester/tbt_09do.t similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_09do.t rename to dist/Test-Simple/t/Legacy/Tester/tbt_09do.t diff --git a/dist/Test-Simple/t/Tester/tbt_09do_script.pl b/dist/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl similarity index 100% rename from dist/Test-Simple/t/Tester/tbt_09do_script.pl rename to dist/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl diff --git a/dist/Test-Simple/t/auto.t b/dist/Test-Simple/t/Legacy/auto.t similarity index 70% rename from dist/Test-Simple/t/auto.t rename to dist/Test-Simple/t/Legacy/auto.t index 0010342ee94..5a5de4fb5b7 100644 --- a/dist/Test-Simple/t/auto.t +++ b/dist/Test-Simple/t/Legacy/auto.t @@ -1,9 +1,9 @@ use strict; use warnings; -use lib 't'; +use lib 't/lib'; -use Test::Tester tests => 5; +use Test::Tester tests => 6; use SmallTest; @@ -28,3 +28,9 @@ use MyTest; } is_eq(ref(SmallTest::getTest()), "Test::Tester::Delegate"); + +is_eq( + SmallTest::getTest()->can('ok'), + Test::Builder->can('ok'), + "Delegate->can() returns the sub from the inner object", +); diff --git a/dist/Test-Simple/t/bad_plan.t b/dist/Test-Simple/t/Legacy/bad_plan.t similarity index 91% rename from dist/Test-Simple/t/bad_plan.t rename to dist/Test-Simple/t/Legacy/bad_plan.t index d2d48b6103e..80e0e65bcaa 100644 --- a/dist/Test-Simple/t/bad_plan.t +++ b/dist/Test-Simple/t/Legacy/bad_plan.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/bail_out.t b/dist/Test-Simple/t/Legacy/bail_out.t similarity index 74% rename from dist/Test-Simple/t/bail_out.t rename to dist/Test-Simple/t/Legacy/bail_out.t index 8279727b113..d1c3dce7219 100644 --- a/dist/Test-Simple/t/bail_out.t +++ b/dist/Test-Simple/t/Legacy/bail_out.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; @@ -14,6 +15,9 @@ BEGIN { *CORE::GLOBAL::exit = sub { $Exit_Code = shift; }; } +# This test uses multiple builders, the real one is using the top hub, we need +# to fix the ending. +Test2::API::test2_stack()->top->set_no_ending(1); use Test::Builder; use Test::More; diff --git a/dist/Test-Simple/t/buffer.t b/dist/Test-Simple/t/Legacy/buffer.t similarity index 89% rename from dist/Test-Simple/t/buffer.t rename to dist/Test-Simple/t/Legacy/buffer.t index 51f24787ace..6039e4a6f72 100644 --- a/dist/Test-Simple/t/buffer.t +++ b/dist/Test-Simple/t/Legacy/buffer.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/c_flag.t b/dist/Test-Simple/t/Legacy/c_flag.t similarity index 100% rename from dist/Test-Simple/t/c_flag.t rename to dist/Test-Simple/t/Legacy/c_flag.t diff --git a/dist/Test-Simple/t/capture.t b/dist/Test-Simple/t/Legacy/capture.t similarity index 91% rename from dist/Test-Simple/t/capture.t rename to dist/Test-Simple/t/Legacy/capture.t index 1a20d79adc0..f9103bd6aa0 100644 --- a/dist/Test-Simple/t/capture.t +++ b/dist/Test-Simple/t/Legacy/capture.t @@ -5,7 +5,9 @@ use Test::Tester; my $Test = Test::Builder->new; $Test->plan(tests => 3); -my $cap = Test::Tester->capture; +my $cap; + +$cap = Test::Tester->capture; { no warnings 'redefine'; diff --git a/dist/Test-Simple/t/check_tests.t b/dist/Test-Simple/t/Legacy/check_tests.t similarity index 100% rename from dist/Test-Simple/t/check_tests.t rename to dist/Test-Simple/t/Legacy/check_tests.t diff --git a/dist/Test-Simple/t/circular_data.t b/dist/Test-Simple/t/Legacy/circular_data.t similarity index 95% rename from dist/Test-Simple/t/circular_data.t rename to dist/Test-Simple/t/Legacy/circular_data.t index 928507bd215..2fd819e1f4a 100644 --- a/dist/Test-Simple/t/circular_data.t +++ b/dist/Test-Simple/t/Legacy/circular_data.t @@ -4,7 +4,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/cmp_ok.t b/dist/Test-Simple/t/Legacy/cmp_ok.t similarity index 100% rename from dist/Test-Simple/t/cmp_ok.t rename to dist/Test-Simple/t/Legacy/cmp_ok.t diff --git a/dist/Test-Simple/t/depth.t b/dist/Test-Simple/t/Legacy/depth.t similarity index 95% rename from dist/Test-Simple/t/depth.t rename to dist/Test-Simple/t/Legacy/depth.t index acbf07f2b19..55d0d7c6345 100644 --- a/dist/Test-Simple/t/depth.t +++ b/dist/Test-Simple/t/Legacy/depth.t @@ -1,7 +1,7 @@ use strict; use warnings; -use lib 't'; +use lib 't/lib'; use Test::Tester; diff --git a/dist/Test-Simple/t/diag.t b/dist/Test-Simple/t/Legacy/diag.t similarity index 90% rename from dist/Test-Simple/t/diag.t rename to dist/Test-Simple/t/Legacy/diag.t index e78053713f7..bc10975b113 100644 --- a/dist/Test-Simple/t/diag.t +++ b/dist/Test-Simple/t/Legacy/diag.t @@ -1,27 +1,26 @@ #!perl -w +use strict; -BEGIN { - if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); - } - else { - unshift @INC, 't/lib'; - } -} - +use Test2::Util qw/CAN_THREAD/; # Turn on threads here, if available, since this test tends to find # lots of threading bugs. -use Config; BEGIN { - if( $] >= 5.008001 && $Config{useithreads} ) { + if (CAN_THREAD) { require threads; - 'threads'->import; + threads->import; } } - -use strict; +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} use Test::Builder::NoOutput; use Test::More tests => 7; diff --git a/dist/Test-Simple/t/died.t b/dist/Test-Simple/t/Legacy/died.t similarity index 90% rename from dist/Test-Simple/t/died.t rename to dist/Test-Simple/t/Legacy/died.t index 9a326633aed..c26e86b541d 100644 --- a/dist/Test-Simple/t/died.t +++ b/dist/Test-Simple/t/Legacy/died.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } @@ -40,5 +41,5 @@ ERR $TB->is_eq($?, 250, "exit code"); - exit grep { !$_ } $TB->summary; + $? = grep { !$_ } $TB->summary; } diff --git a/dist/Test-Simple/t/dont_overwrite_die_handler.t b/dist/Test-Simple/t/Legacy/dont_overwrite_die_handler.t similarity index 65% rename from dist/Test-Simple/t/dont_overwrite_die_handler.t rename to dist/Test-Simple/t/Legacy/dont_overwrite_die_handler.t index db5cb47986d..09b700787d1 100644 --- a/dist/Test-Simple/t/dont_overwrite_die_handler.t +++ b/dist/Test-Simple/t/Legacy/dont_overwrite_die_handler.t @@ -3,17 +3,22 @@ use Config; # To prevent conflict with some strawberry-portable versions BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } +use Carp qw/cluck/; + # Make sure this is in place before Test::More is loaded. +my $started = 0; my $handler_called; BEGIN { - $SIG{__DIE__} = sub { $handler_called++ }; + $SIG{__DIE__} = sub { $handler_called++; cluck 'Died early!' unless $started }; } use Test::More tests => 2; +$started = 1; ok !eval { die }; is $handler_called, 1, 'existing DIE handler not overridden'; diff --git a/dist/Test-Simple/t/eq_set.t b/dist/Test-Simple/t/Legacy/eq_set.t similarity index 90% rename from dist/Test-Simple/t/eq_set.t rename to dist/Test-Simple/t/Legacy/eq_set.t index bd0c8d6cce2..fbdc52db1fa 100644 --- a/dist/Test-Simple/t/eq_set.t +++ b/dist/Test-Simple/t/Legacy/eq_set.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/exit.t b/dist/Test-Simple/t/Legacy/exit.t similarity index 98% rename from dist/Test-Simple/t/exit.t rename to dist/Test-Simple/t/Legacy/exit.t index bc492bee232..e32e986314c 100644 --- a/dist/Test-Simple/t/exit.t +++ b/dist/Test-Simple/t/Legacy/exit.t @@ -5,7 +5,8 @@ package My::Test; BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/explain.t b/dist/Test-Simple/t/Legacy/explain.t similarity index 90% rename from dist/Test-Simple/t/explain.t rename to dist/Test-Simple/t/Legacy/explain.t index 73665e2da6b..cf2f550e950 100644 --- a/dist/Test-Simple/t/explain.t +++ b/dist/Test-Simple/t/Legacy/explain.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/Legacy/explain_err_vars.t b/dist/Test-Simple/t/Legacy/explain_err_vars.t new file mode 100644 index 00000000000..6f5487f6706 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/explain_err_vars.t @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test::More; + +$@ = 'foo'; +explain { 1 => 1 }; +is($@, 'foo', "preserved \$@"); + +done_testing; diff --git a/dist/Test-Simple/t/extra.t b/dist/Test-Simple/t/Legacy/extra.t similarity index 95% rename from dist/Test-Simple/t/extra.t rename to dist/Test-Simple/t/Legacy/extra.t index b6bf4d75daa..55a0007d49d 100644 --- a/dist/Test-Simple/t/extra.t +++ b/dist/Test-Simple/t/Legacy/extra.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/extra_one.t b/dist/Test-Simple/t/Legacy/extra_one.t similarity index 93% rename from dist/Test-Simple/t/extra_one.t rename to dist/Test-Simple/t/Legacy/extra_one.t index f9e673ec561..d77404e15de 100644 --- a/dist/Test-Simple/t/extra_one.t +++ b/dist/Test-Simple/t/Legacy/extra_one.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/fail-like.t b/dist/Test-Simple/t/Legacy/fail-like.t similarity index 90% rename from dist/Test-Simple/t/fail-like.t rename to dist/Test-Simple/t/Legacy/fail-like.t index 0520a923328..6545507e3a8 100644 --- a/dist/Test-Simple/t/fail-like.t +++ b/dist/Test-Simple/t/Legacy/fail-like.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; @@ -57,14 +58,14 @@ ERR } { - # line 61 + # line 62 like("foo", "not a regex"); $TB->is_eq($out->read, <is_eq($err->read, <summary); + $? = scalar grep { !$_ } $TB->summary; } diff --git a/dist/Test-Simple/t/fail-more.t b/dist/Test-Simple/t/Legacy/fail-more.t similarity index 97% rename from dist/Test-Simple/t/fail-more.t rename to dist/Test-Simple/t/Legacy/fail-more.t index 7f8c5f5fb40..5cb373edef9 100644 --- a/dist/Test-Simple/t/fail-more.t +++ b/dist/Test-Simple/t/Legacy/fail-more.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; @@ -130,11 +131,11 @@ OUT ERR #line 132 -isnt("foo", "foo",'foo isnt foo?' ); +isn't("foo", "foo",'foo isn\'t foo?' ); out_ok( <is_eq( $err->read, <is_eq( $err->read, < 1; use Dev::Null; diff --git a/dist/Test-Simple/t/Legacy/fork.t b/dist/Test-Simple/t/Legacy/fork.t new file mode 100644 index 00000000000..134f7a18590 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/fork.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl -w +use strict; +use warnings; + +use Test2::Util qw/CAN_FORK/; +BEGIN { + unless(CAN_FORK) { + require Test::More; + Test::More->import(skip_all => "fork is not supported"); + } +} + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use Test::More; +plan tests => 1; + +if( fork ) { # parent + pass("Only the parent should process the ending, not the child"); +} +else { + exit; # child +} + diff --git a/dist/Test-Simple/t/harness_active.t b/dist/Test-Simple/t/Legacy/harness_active.t similarity index 96% rename from dist/Test-Simple/t/harness_active.t rename to dist/Test-Simple/t/Legacy/harness_active.t index c53a1d82f99..7b027a7b404 100644 --- a/dist/Test-Simple/t/harness_active.t +++ b/dist/Test-Simple/t/Legacy/harness_active.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/import.t b/dist/Test-Simple/t/Legacy/import.t similarity index 81% rename from dist/Test-Simple/t/import.t rename to dist/Test-Simple/t/Legacy/import.t index 7b04ee1edfd..68a36138bc9 100644 --- a/dist/Test-Simple/t/import.t +++ b/dist/Test-Simple/t/Legacy/import.t @@ -1,6 +1,7 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/is_deeply_dne_bug.t b/dist/Test-Simple/t/Legacy/is_deeply_dne_bug.t similarity index 94% rename from dist/Test-Simple/t/is_deeply_dne_bug.t rename to dist/Test-Simple/t/Legacy/is_deeply_dne_bug.t index be00a8ed664..f4578a6460e 100644 --- a/dist/Test-Simple/t/is_deeply_dne_bug.t +++ b/dist/Test-Simple/t/Legacy/is_deeply_dne_bug.t @@ -7,7 +7,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/is_deeply_fail.t b/dist/Test-Simple/t/Legacy/is_deeply_fail.t similarity index 97% rename from dist/Test-Simple/t/is_deeply_fail.t rename to dist/Test-Simple/t/Legacy/is_deeply_fail.t index 62e726c4853..21efe87a257 100644 --- a/dist/Test-Simple/t/is_deeply_fail.t +++ b/dist/Test-Simple/t/Legacy/is_deeply_fail.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; @@ -24,7 +25,7 @@ package main; my $TB = Test::Builder->create; -$TB->plan(tests => 100); +$TB->plan(tests => 102); # Utility testing functions. sub ok ($;$) { @@ -418,3 +419,11 @@ ERR ok !is_deeply( {x => ''}, {x => undef}, "{x => ''} != {x => undef}" ); is( $out, "not ok 41 - {x => ''} != {x => undef}\n" ); } + +# this will also happily fail before 5.10, even though there's no VSTRING ref type +{ + my $version1 = v1.2.3; + my $version2 = v1.2.4; + ok !is_deeply( [\\$version1], [\\$version2], "version objects"); + is( $out, "not ok 42 - version objects\n" ); +} diff --git a/dist/Test-Simple/t/is_deeply_with_threads.t b/dist/Test-Simple/t/Legacy/is_deeply_with_threads.t similarity index 78% rename from dist/Test-Simple/t/is_deeply_with_threads.t rename to dist/Test-Simple/t/Legacy/is_deeply_with_threads.t index 6215a1fcd5e..566da7eaa2e 100644 --- a/dist/Test-Simple/t/is_deeply_with_threads.t +++ b/dist/Test-Simple/t/Legacy/is_deeply_with_threads.t @@ -4,7 +4,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; @@ -12,17 +13,17 @@ BEGIN { } use strict; -use Config; - +use Test2::Util qw/CAN_THREAD/; BEGIN { - unless ( $] >= 5.008001 && $Config{'useithreads'} && - eval { require threads; 'threads'->import; 1; }) - { - print "1..0 # Skip no working threads\n"; - exit 0; + unless(CAN_THREAD) { + require Test::More; + Test::More->import(skip_all => "threads are not supported"); } - - unless ( $ENV{PERL_CORE} or $ENV{AUTHOR_TESTING} ) { +} +use threads; + +BEGIN { + unless ( $ENV{AUTHOR_TESTING} ) { print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; exit 0; } diff --git a/dist/Test-Simple/t/missing.t b/dist/Test-Simple/t/Legacy/missing.t similarity index 93% rename from dist/Test-Simple/t/missing.t rename to dist/Test-Simple/t/Legacy/missing.t index c2ea1f92d64..3b8f1fa9b4b 100644 --- a/dist/Test-Simple/t/missing.t +++ b/dist/Test-Simple/t/Legacy/missing.t @@ -1,6 +1,8 @@ +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/new_ok.t b/dist/Test-Simple/t/Legacy/new_ok.t similarity index 70% rename from dist/Test-Simple/t/new_ok.t rename to dist/Test-Simple/t/Legacy/new_ok.t index 5ae4aff470e..d53f535d1c0 100644 --- a/dist/Test-Simple/t/new_ok.t +++ b/dist/Test-Simple/t/Legacy/new_ok.t @@ -36,6 +36,7 @@ use Test::More tests => 13; } # And what if we give it nothing? -eval q(new_ok();); -like $@, qr/Not enough arguments for subroutine entry Test::More::new_ok\. Missing \$class at \(eval \d+\) line 1, near "\(\)"\n/; -#is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2; +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/dist/Test-Simple/t/no_plan.t b/dist/Test-Simple/t/Legacy/no_plan.t similarity index 92% rename from dist/Test-Simple/t/no_plan.t rename to dist/Test-Simple/t/Legacy/no_plan.t index 7169f28b6f4..5f392e40e1f 100644 --- a/dist/Test-Simple/t/no_plan.t +++ b/dist/Test-Simple/t/Legacy/no_plan.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/no_tests.t b/dist/Test-Simple/t/Legacy/no_tests.t similarity index 89% rename from dist/Test-Simple/t/no_tests.t rename to dist/Test-Simple/t/Legacy/no_tests.t index 814fa92a624..997add59b2e 100644 --- a/dist/Test-Simple/t/no_tests.t +++ b/dist/Test-Simple/t/Legacy/no_tests.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } @@ -39,5 +40,5 @@ ERR $TB->is_eq($?, 255, "exit code"); - exit grep { !$_ } $TB->summary; + $? = grep { !$_ } $TB->summary; } diff --git a/dist/Test-Simple/t/note.t b/dist/Test-Simple/t/Legacy/note.t similarity index 87% rename from dist/Test-Simple/t/note.t rename to dist/Test-Simple/t/Legacy/note.t index 50e70c21c11..fb98fb40295 100644 --- a/dist/Test-Simple/t/note.t +++ b/dist/Test-Simple/t/Legacy/note.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/overload.t b/dist/Test-Simple/t/Legacy/overload.t similarity index 97% rename from dist/Test-Simple/t/overload.t rename to dist/Test-Simple/t/Legacy/overload.t index b9cc871d192..a86103746b3 100644 --- a/dist/Test-Simple/t/overload.t +++ b/dist/Test-Simple/t/Legacy/overload.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/overload_threads.t b/dist/Test-Simple/t/Legacy/overload_threads.t similarity index 86% rename from dist/Test-Simple/t/overload_threads.t rename to dist/Test-Simple/t/Legacy/overload_threads.t index 9173355f7e1..56bdaec5bc9 100644 --- a/dist/Test-Simple/t/overload_threads.t +++ b/dist/Test-Simple/t/Legacy/overload_threads.t @@ -1,8 +1,10 @@ #!perl -w +use Test2::Util qw/CAN_THREAD/; BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; @@ -13,7 +15,7 @@ chdir 't'; BEGIN { # There was a bug with overloaded objects and threads. # See rt.cpan.org 4218 - eval { require threads; 'threads'->import; 1; }; + eval { require threads; 'threads'->import; 1; } if CAN_THREAD; } use Test::More tests => 5; diff --git a/dist/Test-Simple/t/plan.t b/dist/Test-Simple/t/Legacy/plan.t similarity index 90% rename from dist/Test-Simple/t/plan.t rename to dist/Test-Simple/t/Legacy/plan.t index 0814f997d9b..0d3ce89edb1 100644 --- a/dist/Test-Simple/t/plan.t +++ b/dist/Test-Simple/t/Legacy/plan.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/plan_bad.t b/dist/Test-Simple/t/Legacy/plan_bad.t similarity index 84% rename from dist/Test-Simple/t/plan_bad.t rename to dist/Test-Simple/t/Legacy/plan_bad.t index f22f4e342a8..179356dbc1d 100644 --- a/dist/Test-Simple/t/plan_bad.t +++ b/dist/Test-Simple/t/Legacy/plan_bad.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } @@ -18,7 +19,7 @@ is $@, sprintf "Number of tests must be a positive integer. You gave it 'no_pla my $foo = []; my @foo = ($foo, 2, 3); ok !eval { $tb->plan( tests => @foo ) }; -is $@, sprintf "Too many arguments for method Test::Builder::plan. Want: 1-3, but got: 5 at %s line %d.\n", $0, __LINE__ - 1; +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; diff --git a/dist/Test-Simple/t/plan_is_noplan.t b/dist/Test-Simple/t/Legacy/plan_is_noplan.t similarity index 86% rename from dist/Test-Simple/t/plan_is_noplan.t rename to dist/Test-Simple/t/Legacy/plan_is_noplan.t index 1bd59fa667b..1e696042eff 100644 --- a/dist/Test-Simple/t/plan_is_noplan.t +++ b/dist/Test-Simple/t/Legacy/plan_is_noplan.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/plan_no_plan.t b/dist/Test-Simple/t/Legacy/plan_no_plan.t similarity index 94% rename from dist/Test-Simple/t/plan_no_plan.t rename to dist/Test-Simple/t/Legacy/plan_no_plan.t index ffb1d9c3845..3111592e97f 100644 --- a/dist/Test-Simple/t/plan_no_plan.t +++ b/dist/Test-Simple/t/Legacy/plan_no_plan.t @@ -1,6 +1,7 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/plan_shouldnt_import.t b/dist/Test-Simple/t/Legacy/plan_shouldnt_import.t similarity index 85% rename from dist/Test-Simple/t/plan_shouldnt_import.t rename to dist/Test-Simple/t/Legacy/plan_shouldnt_import.t index e75ec980250..b6eb0642446 100644 --- a/dist/Test-Simple/t/plan_shouldnt_import.t +++ b/dist/Test-Simple/t/Legacy/plan_shouldnt_import.t @@ -4,7 +4,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/plan_skip_all.t b/dist/Test-Simple/t/Legacy/plan_skip_all.t similarity index 76% rename from dist/Test-Simple/t/plan_skip_all.t rename to dist/Test-Simple/t/Legacy/plan_skip_all.t index f4bcf69a61e..528df5f50d4 100644 --- a/dist/Test-Simple/t/plan_skip_all.t +++ b/dist/Test-Simple/t/Legacy/plan_skip_all.t @@ -1,6 +1,7 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/require_ok.t b/dist/Test-Simple/t/Legacy/require_ok.t similarity index 93% rename from dist/Test-Simple/t/require_ok.t rename to dist/Test-Simple/t/Legacy/require_ok.t index ee6454c0cbf..463a007599c 100644 --- a/dist/Test-Simple/t/require_ok.t +++ b/dist/Test-Simple/t/Legacy/require_ok.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/run_test.t b/dist/Test-Simple/t/Legacy/run_test.t similarity index 100% rename from dist/Test-Simple/t/run_test.t rename to dist/Test-Simple/t/Legacy/run_test.t diff --git a/dist/Test-Simple/t/simple.t b/dist/Test-Simple/t/Legacy/simple.t similarity index 78% rename from dist/Test-Simple/t/simple.t rename to dist/Test-Simple/t/Legacy/simple.t index 7b15d184e19..7297e9d6dd1 100644 --- a/dist/Test-Simple/t/simple.t +++ b/dist/Test-Simple/t/Legacy/simple.t @@ -1,6 +1,7 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/skip.t b/dist/Test-Simple/t/Legacy/skip.t similarity index 81% rename from dist/Test-Simple/t/skip.t rename to dist/Test-Simple/t/Legacy/skip.t index dbcc16e64e8..f2ea9fbf201 100644 --- a/dist/Test-Simple/t/skip.t +++ b/dist/Test-Simple/t/Legacy/skip.t @@ -2,11 +2,12 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } -use Test::More tests => 15; +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. @@ -83,16 +84,15 @@ SKIP: { pass("This is supposed to run, too"); } -# with cperl types this is a compile-time error -#{ -# 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/; -#} +{ + 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/dist/Test-Simple/t/skipall.t b/dist/Test-Simple/t/Legacy/skipall.t similarity index 88% rename from dist/Test-Simple/t/skipall.t rename to dist/Test-Simple/t/Legacy/skipall.t index fbe71612dc3..5491be126e8 100644 --- a/dist/Test-Simple/t/skipall.t +++ b/dist/Test-Simple/t/Legacy/skipall.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/Legacy/strays.t b/dist/Test-Simple/t/Legacy/strays.t new file mode 100644 index 00000000000..7478bfef473 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/strays.t @@ -0,0 +1,27 @@ +#!/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/dist/Test-Simple/t/subtest/args.t b/dist/Test-Simple/t/Legacy/subtest/args.t similarity index 55% rename from dist/Test-Simple/t/subtest/args.t rename to dist/Test-Simple/t/Legacy/subtest/args.t index 860c242c2c2..2c489a7b963 100644 --- a/dist/Test-Simple/t/subtest/args.t +++ b/dist/Test-Simple/t/Legacy/subtest/args.t @@ -17,18 +17,17 @@ use Test::Builder::NoOutput; my $tb = Test::Builder->new; $tb->ok( !eval { $tb->subtest() } ); -#old error: subtest()'s second argument must be a code ref -#new better error: Not enough arguments for subroutine Test::Builder::subtest. Want: 3, but got: 0 +$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); -$tb->ok( !eval { $tb->subtest("foo", undef) } ); +$tb->ok( !eval { $tb->subtest("foo") } ); $tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); +my $foo; $tb->subtest('Arg passing', sub { - my $foo = shift; - my $child = Test::Builder->new; - $child->is_eq($foo, 'foo'); - $child->done_testing; - $child->finalize; + $foo = shift; + $tb->ok(1); }, 'foo'); +$tb->is_eq($foo, 'foo'); + $tb->done_testing(); diff --git a/dist/Test-Simple/t/subtest/bail_out.t b/dist/Test-Simple/t/Legacy/subtest/bail_out.t similarity index 84% rename from dist/Test-Simple/t/subtest/bail_out.t rename to dist/Test-Simple/t/Legacy/subtest/bail_out.t index 70dc9ac56f4..bc77325f169 100644 --- a/dist/Test-Simple/t/subtest/bail_out.t +++ b/dist/Test-Simple/t/Legacy/subtest/bail_out.t @@ -12,7 +12,7 @@ BEGIN { my $Exit_Code; BEGIN { - *CORE::GLOBAL::exit = sub { $Exit_Code = shift; }; + *CORE::GLOBAL::exit = sub { $Exit_Code = shift; goto XXX}; } use Test::Builder; @@ -43,13 +43,15 @@ subtest 'bar' => sub { ok 'sub_baz'; }; +XXX: + $Test->is_eq( $output, <<'OUT' ); 1..4 ok 1 - # Subtest: bar +# Subtest: bar 1..3 ok 1 - # Subtest: sub_bar + # Subtest: sub_bar 1..3 ok 1 ok 2 @@ -57,3 +59,5 @@ Bail out! ROCKS FALL! EVERYONE DIES! OUT $Test->is_eq( $Exit_Code, 255 ); + +Test2::API::test2_stack()->top->set_no_ending(1); diff --git a/dist/Test-Simple/t/subtest/basic.t b/dist/Test-Simple/t/Legacy/subtest/basic.t similarity index 87% rename from dist/Test-Simple/t/subtest/basic.t rename to dist/Test-Simple/t/Legacy/subtest/basic.t index 93780a9da2f..485057110bc 100644 --- a/dist/Test-Simple/t/subtest/basic.t +++ b/dist/Test-Simple/t/Legacy/subtest/basic.t @@ -15,7 +15,7 @@ use warnings; use Test::Builder::NoOutput; -use Test::More tests => 19; +use Test::More tests => 12; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; @@ -150,15 +150,11 @@ END 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 @@ -168,15 +164,11 @@ END { 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 @@ -209,6 +201,6 @@ END 1..1 not ok 1 - No tests run for subtest "Child of $0" END - like $tb->read, qr/\Q$expected/, + like $tb->read, qr/\Q$expected\E/, 'Not running subtests should make the parent test fail'; } diff --git a/dist/Test-Simple/t/subtest/die.t b/dist/Test-Simple/t/Legacy/subtest/die.t similarity index 100% rename from dist/Test-Simple/t/subtest/die.t rename to dist/Test-Simple/t/Legacy/subtest/die.t diff --git a/dist/Test-Simple/t/subtest/do.t b/dist/Test-Simple/t/Legacy/subtest/do.t similarity index 83% rename from dist/Test-Simple/t/subtest/do.t rename to dist/Test-Simple/t/Legacy/subtest/do.t index 1e188b7ce19..c9efdac8926 100644 --- a/dist/Test-Simple/t/subtest/do.t +++ b/dist/Test-Simple/t/Legacy/subtest/do.t @@ -7,7 +7,7 @@ use Test::More; pass("First"); -my $file = "./t/subtest/for_do_t.test"; +my $file = "./t/Legacy/subtest/for_do_t.test"; ok -e $file, "subtest test file exists"; subtest $file => sub { do $file }; diff --git a/dist/Test-Simple/t/Legacy/subtest/events.t b/dist/Test-Simple/t/Legacy/subtest/events.t new file mode 100644 index 00000000000..0fad76dde82 --- /dev/null +++ b/dist/Test-Simple/t/Legacy/subtest/events.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use Test::More; +use Test2::API qw/intercept/; + +my $events = intercept { + subtest foo => sub { + ok(1, "pass"); + }; +}; + +my $st = $events->[-1]; +isa_ok($st, 'Test2::Event::Subtest'); +ok(my $id = $st->subtest_id, "got an id"); +for my $se (@{$st->subevents}) { + is($se->in_subtest, $id, "set subtest_id on child event"); +} + +done_testing; diff --git a/dist/Test-Simple/t/subtest/for_do_t.test b/dist/Test-Simple/t/Legacy/subtest/for_do_t.test similarity index 100% rename from dist/Test-Simple/t/subtest/for_do_t.test rename to dist/Test-Simple/t/Legacy/subtest/for_do_t.test diff --git a/dist/Test-Simple/t/Legacy/subtest/fork.t b/dist/Test-Simple/t/Legacy/subtest/fork.t new file mode 100644 index 00000000000..aaa6cab877b --- /dev/null +++ b/dist/Test-Simple/t/Legacy/subtest/fork.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w +use strict; +use warnings; + +use Test2::Util qw/CAN_FORK/; +BEGIN { + unless(CAN_FORK) { + require Test::More; + Test::More->import(skip_all => "fork is not supported"); + } +} + +use IO::Pipe; +use Test::Builder; +use Test::More; + +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. + my $tb = Test::Builder->new; + $tb->output($pipe); + $tb->failure_output($pipe); + $tb->todo_output($pipe); + + diag 'Child Done'; + exit 0; + } +}; + diff --git a/dist/Test-Simple/t/subtest/implicit_done.t b/dist/Test-Simple/t/Legacy/subtest/implicit_done.t similarity index 100% rename from dist/Test-Simple/t/subtest/implicit_done.t rename to dist/Test-Simple/t/Legacy/subtest/implicit_done.t diff --git a/dist/Test-Simple/t/subtest/line_numbers.t b/dist/Test-Simple/t/Legacy/subtest/line_numbers.t similarity index 94% rename from dist/Test-Simple/t/subtest/line_numbers.t rename to dist/Test-Simple/t/Legacy/subtest/line_numbers.t index 7a20a60ae6b..2ad74571c27 100644 --- a/dist/Test-Simple/t/subtest/line_numbers.t +++ b/dist/Test-Simple/t/Legacy/subtest/line_numbers.t @@ -26,7 +26,7 @@ $ENV{HARNESS_ACTIVE} = 0; our %line; { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1"); test_out(" not ok 2"); @@ -47,7 +47,7 @@ our %line; test_test("un-named inner tests"); } { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1 - first is good"); test_out(" not ok 2 - second is bad"); @@ -78,7 +78,7 @@ sub run_the_subtest { }; BEGIN{ $line{outerfail3} = __LINE__ } } { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1 - first is good"); test_out(" not ok 2 - second is bad"); @@ -95,7 +95,7 @@ sub run_the_subtest { test_test("subtest() called from a sub"); } { - test_out( " # Subtest: namehere"); + test_out( "# Subtest: namehere"); test_out( " 1..0"); test_err( " # No tests run!"); test_out( 'not ok 1 - No tests run for subtest "namehere"'); @@ -109,7 +109,7 @@ sub run_the_subtest { test_test("lineno in 'No tests run' diagnostic"); } { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..1"); test_out(" not ok 1 - foo is bar"); test_err(" # Failed test 'foo is bar'"); diff --git a/dist/Test-Simple/t/subtest/plan.t b/dist/Test-Simple/t/Legacy/subtest/plan.t similarity index 93% rename from dist/Test-Simple/t/subtest/plan.t rename to dist/Test-Simple/t/Legacy/subtest/plan.t index 215fcd8c68c..7e944ab2833 100644 --- a/dist/Test-Simple/t/subtest/plan.t +++ b/dist/Test-Simple/t/Legacy/subtest/plan.t @@ -15,13 +15,14 @@ use warnings; use Test::Builder::NoOutput; -use Test::More tests => 5; +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; diff --git a/dist/Test-Simple/t/subtest/predicate.t b/dist/Test-Simple/t/Legacy/subtest/predicate.t similarity index 95% rename from dist/Test-Simple/t/subtest/predicate.t rename to dist/Test-Simple/t/Legacy/subtest/predicate.t index 4e29a426b18..73b9c81056f 100644 --- a/dist/Test-Simple/t/subtest/predicate.t +++ b/dist/Test-Simple/t/Legacy/subtest/predicate.t @@ -40,7 +40,7 @@ sub foobar_ok ($;$) { }; } { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); @@ -65,7 +65,7 @@ sub foobar_ok_2 ($;$) { foobar_ok($value, $name); } { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); @@ -95,7 +95,7 @@ sub barfoo_ok ($;$) { }); } { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); @@ -120,7 +120,7 @@ sub barfoo_ok_2 ($;$) { barfoo_ok($value, $name); } { - test_out(" # Subtest: namehere"); + test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); @@ -138,10 +138,10 @@ sub barfoo_ok_2 ($;$) { # A subtest-based predicate called from within a subtest { - test_out(" # Subtest: outergroup"); + test_out("# Subtest: outergroup"); test_out(" 1..2"); test_out(" ok 1 - this passes"); - test_out(" # Subtest: namehere"); + test_out(" # Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); diff --git a/dist/Test-Simple/t/subtest/singleton.t b/dist/Test-Simple/t/Legacy/subtest/singleton.t similarity index 100% rename from dist/Test-Simple/t/subtest/singleton.t rename to dist/Test-Simple/t/Legacy/subtest/singleton.t diff --git a/dist/Test-Simple/t/subtest/threads.t b/dist/Test-Simple/t/Legacy/subtest/threads.t similarity index 56% rename from dist/Test-Simple/t/subtest/threads.t rename to dist/Test-Simple/t/Legacy/subtest/threads.t index 0d70b1e6e58..b1ac199dac8 100644 --- a/dist/Test-Simple/t/subtest/threads.t +++ b/dist/Test-Simple/t/Legacy/subtest/threads.t @@ -3,15 +3,14 @@ use strict; use warnings; -use Config; +use Test2::Util qw/CAN_THREAD/; BEGIN { - unless ( $] >= 5.008001 && $Config{'useithreads'} && - eval { require threads; 'threads'->import; 1; }) - { - print "1..0 # Skip: no working threads\n"; - exit 0; + unless(CAN_THREAD) { + require Test::More; + Test::More->import(skip_all => "threads are not supported"); } } +use threads; use Test::More; diff --git a/dist/Test-Simple/t/subtest/todo.t b/dist/Test-Simple/t/Legacy/subtest/todo.t similarity index 98% rename from dist/Test-Simple/t/subtest/todo.t rename to dist/Test-Simple/t/Legacy/subtest/todo.t index 7269da9b951..7c7eb589ef9 100644 --- a/dist/Test-Simple/t/subtest/todo.t +++ b/dist/Test-Simple/t/Legacy/subtest/todo.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w - # Test todo subtests. # # A subtest in a todo context should have all of its diagnostic output @@ -51,8 +50,8 @@ sub test_subtest_in_todo { foreach my $combo (@test_combos) { my ($set_via, $todo_reason, $level) = @$combo; - test_out( - " # Subtest: xxx", + test_out( map { my $x = $_; $x =~ s/\s+$//g; $x } + "# Subtest: xxx", @outlines, "not ok 1 - $xxx # TODO $todo_reason", "# Failed (TODO) test '$xxx'", diff --git a/dist/Test-Simple/t/subtest/wstat.t b/dist/Test-Simple/t/Legacy/subtest/wstat.t similarity index 100% rename from dist/Test-Simple/t/subtest/wstat.t rename to dist/Test-Simple/t/Legacy/subtest/wstat.t diff --git a/dist/Test-Simple/t/tbm_doesnt_set_exported_to.t b/dist/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t similarity index 90% rename from dist/Test-Simple/t/tbm_doesnt_set_exported_to.t rename to dist/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t index a2f7dffef34..8bdd17753b1 100644 --- a/dist/Test-Simple/t/tbm_doesnt_set_exported_to.t +++ b/dist/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/thread_taint.t b/dist/Test-Simple/t/Legacy/thread_taint.t similarity index 100% rename from dist/Test-Simple/t/thread_taint.t rename to dist/Test-Simple/t/Legacy/thread_taint.t diff --git a/dist/Test-Simple/t/threads.t b/dist/Test-Simple/t/Legacy/threads.t similarity index 61% rename from dist/Test-Simple/t/threads.t rename to dist/Test-Simple/t/Legacy/threads.t index 12b6f309d9c..91e47da7d7f 100644 --- a/dist/Test-Simple/t/threads.t +++ b/dist/Test-Simple/t/Legacy/threads.t @@ -1,18 +1,20 @@ #!/usr/bin/perl -w +use strict; +use warnings; +use Test2::Util qw/CAN_THREAD/; BEGIN { - if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + unless(CAN_THREAD) { + require Test::More; + Test::More->import(skip_all => "threads are not supported"); } } +use threads; -use Config; BEGIN { - unless ( $] >= 5.008001 && $Config{'useithreads'} && - eval { require threads; 'threads'->import; 1; }) - { - print "1..0 # Skip: no working threads\n"; - exit 0; + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/todo.t b/dist/Test-Simple/t/Legacy/todo.t similarity index 97% rename from dist/Test-Simple/t/todo.t rename to dist/Test-Simple/t/Legacy/todo.t index 51d38593c6a..7d28846857f 100644 --- a/dist/Test-Simple/t/todo.t +++ b/dist/Test-Simple/t/Legacy/todo.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } @@ -139,7 +140,7 @@ is $is_todo, 'Nesting TODO', eval { $builder->todo_end; }; -is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 2; +is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 3; { diff --git a/dist/Test-Simple/t/undef.t b/dist/Test-Simple/t/Legacy/undef.t similarity index 97% rename from dist/Test-Simple/t/undef.t rename to dist/Test-Simple/t/Legacy/undef.t index 23aae20944b..2c8cace491a 100644 --- a/dist/Test-Simple/t/undef.t +++ b/dist/Test-Simple/t/Legacy/undef.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = ('../../lib', 't/lib'); + chdir 't'; + @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; diff --git a/dist/Test-Simple/t/use_ok.t b/dist/Test-Simple/t/Legacy/use_ok.t similarity index 100% rename from dist/Test-Simple/t/use_ok.t rename to dist/Test-Simple/t/Legacy/use_ok.t diff --git a/dist/Test-Simple/t/useing.t b/dist/Test-Simple/t/Legacy/useing.t similarity index 87% rename from dist/Test-Simple/t/useing.t rename to dist/Test-Simple/t/Legacy/useing.t index 220ce2ebdda..c4ce5071270 100644 --- a/dist/Test-Simple/t/useing.t +++ b/dist/Test-Simple/t/Legacy/useing.t @@ -1,6 +1,7 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } diff --git a/dist/Test-Simple/t/utf8.t b/dist/Test-Simple/t/Legacy/utf8.t similarity index 95% rename from dist/Test-Simple/t/utf8.t rename to dist/Test-Simple/t/Legacy/utf8.t index 8e1b303ad11..2930226e3e9 100644 --- a/dist/Test-Simple/t/utf8.t +++ b/dist/Test-Simple/t/Legacy/utf8.t @@ -2,7 +2,8 @@ BEGIN { if( $ENV{PERL_CORE} ) { - @INC = '../../lib'; + chdir 't'; + @INC = '../lib'; } } @@ -42,9 +43,9 @@ SKIP: { 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"; @@ -55,7 +56,7 @@ SKIP: { # Test utf8 is ok. { my $uni = "\x{11e}"; - + my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; diff --git a/dist/Test-Simple/t/versions.t b/dist/Test-Simple/t/Legacy/versions.t similarity index 100% rename from dist/Test-Simple/t/versions.t rename to dist/Test-Simple/t/Legacy/versions.t diff --git a/dist/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t b/dist/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t new file mode 100644 index 00000000000..21c712b5e4a --- /dev/null +++ b/dist/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::API qw/intercept/; + +plan 4; + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings => @_ }; + require Test::Builder; +}; + +is(@warnings, 3, "got 3 warnings"); + +like( + $warnings[0], + qr/Test::Builder was loaded after Test2 initialization, this is not recommended/, + "Warn about late Test::Builder load" +); + +like( + $warnings[1], + qr/Formatter Test::Builder::Formatter loaded too late to be used as the global formatter/, + "Got the formatter warning" +); + +like( + $warnings[2], + qr/The current formatter does not support 'no_header'/, + "Formatter does not support no_header", +); + + diff --git a/dist/Test-Simple/t/Legacy_And_Test2/hidden_warnings.t b/dist/Test-Simple/t/Legacy_And_Test2/hidden_warnings.t new file mode 100644 index 00000000000..1819be3399c --- /dev/null +++ b/dist/Test-Simple/t/Legacy_And_Test2/hidden_warnings.t @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; +use Test2::API qw( context_do ); + +$SIG{__WARN__} = sub { + context_do { shift->throw("oops\n"); } + $_[0]; +}; + +my $array_var = []; +eval { warn "trigger warning" }; +my $err = $@; +like( + $err, + qr/oops/, + "Got expected error" +); + +done_testing(); diff --git a/dist/Test-Simple/t/Test2/acceptance/try_it_done_testing.t b/dist/Test-Simple/t/Test2/acceptance/try_it_done_testing.t new file mode 100644 index 00000000000..7badf3e6eed --- /dev/null +++ b/dist/Test-Simple/t/Test2/acceptance/try_it_done_testing.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test2::API qw/context/; + +sub done_testing { + my $ctx = context(); + + die "Test Already ended!" if $ctx->hub->ended; + $ctx->hub->finalize($ctx->trace, 1); + $ctx->release; +} + +sub ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; +} + +ok(1, "First"); +ok(1, "Second"); + +done_testing; + +1; diff --git a/dist/Test-Simple/t/Test2/acceptance/try_it_fork.t b/dist/Test-Simple/t/Test2/acceptance/try_it_fork.t new file mode 100644 index 00000000000..f6d72f643e5 --- /dev/null +++ b/dist/Test-Simple/t/Test2/acceptance/try_it_fork.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test2::Util qw/CAN_FORK/; +use Test2::IPC; +use Test2::API qw/context/; + +sub plan { + my $ctx = context(); + $ctx->plan(@_); + $ctx->release; +} + +sub ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; +} + +plan(0, skip_all => 'System cannot fork') unless CAN_FORK(); + +plan(6); + +for (1 .. 3) { + my $pid = fork; + die "Failed to fork" unless defined $pid; + next if $pid; + ok(1, "test 1 in pid $$"); + ok(1, "test 2 in pid $$"); + last; +} + +1; diff --git a/dist/Test-Simple/t/Test2/acceptance/try_it_no_plan.t b/dist/Test-Simple/t/Test2/acceptance/try_it_no_plan.t new file mode 100644 index 00000000000..32dde2cc45a --- /dev/null +++ b/dist/Test-Simple/t/Test2/acceptance/try_it_no_plan.t @@ -0,0 +1,24 @@ +use strict; +use warnings; + +use Test2::API qw/context/; + +sub plan { + my $ctx = context(); + $ctx->plan(@_); + $ctx->release; +} + +sub ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; +} + +plan(0, 'no_plan'); + +ok(1, "First"); +ok(1, "Second"); + +1; diff --git a/dist/Test-Simple/t/Test2/acceptance/try_it_plan.t b/dist/Test-Simple/t/Test2/acceptance/try_it_plan.t new file mode 100644 index 00000000000..3656d85d129 --- /dev/null +++ b/dist/Test-Simple/t/Test2/acceptance/try_it_plan.t @@ -0,0 +1,24 @@ +use strict; +use warnings; + +use Test2::API qw/context/; + +sub plan { + my $ctx = context(); + $ctx->plan(@_); + $ctx->release; +} + +sub ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; +} + +plan(2); + +ok(1, "First"); +ok(1, "Second"); + +1; diff --git a/dist/Test-Simple/t/Test2/acceptance/try_it_skip.t b/dist/Test-Simple/t/Test2/acceptance/try_it_skip.t new file mode 100644 index 00000000000..3816eb035a7 --- /dev/null +++ b/dist/Test-Simple/t/Test2/acceptance/try_it_skip.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +use Test2::API qw/context/; + +sub plan { + my $ctx = context(); + $ctx->plan(@_); + $ctx->release; +} + +plan(0, skip_all => 'testing skip all'); + +die "Should not see this"; + +1; diff --git a/dist/Test-Simple/t/Test2/acceptance/try_it_threads.t b/dist/Test-Simple/t/Test2/acceptance/try_it_threads.t new file mode 100644 index 00000000000..e3201585fd2 --- /dev/null +++ b/dist/Test-Simple/t/Test2/acceptance/try_it_threads.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +use Test2::Util qw/CAN_THREAD/; +use Test2::IPC; +use Test2::API qw/context/; + +sub plan { + my $ctx = context(); + $ctx->plan(@_); + $ctx->release; +} + +sub ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; +} + +plan(0, skip_all => 'System does not have threads') unless CAN_THREAD(); + +plan(6); + +require threads; +threads->import; + +for (1 .. 3) { + threads->create(sub { + ok(1, "test 1 in thread " . threads->tid()); + ok(1, "test 2 in thread " . threads->tid()); + }); +} + +1; diff --git a/dist/Test-Simple/t/Test2/acceptance/try_it_todo.t b/dist/Test-Simple/t/Test2/acceptance/try_it_todo.t new file mode 100644 index 00000000000..7a7d7a1ed2b --- /dev/null +++ b/dist/Test-Simple/t/Test2/acceptance/try_it_todo.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test2::API qw/context test2_stack/; + +sub done_testing { + my $ctx = context(); + + die "Test Already ended!" if $ctx->hub->ended; + $ctx->hub->finalize($ctx->trace, 1); + $ctx->release; +} + +sub ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; +} + +sub diag { + my $ctx = context(); + $ctx->diag( join '', @_ ); + $ctx->release; +} + +ok(1, "First"); + +my $filter = test2_stack->top->filter(sub { + my ($hub, $event) = @_; + + # Turn a diag into a note + return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag'; + + # Set todo on ok's + if ($event->isa('Test2::Event::Ok')) { + $event->set_todo('here be dragons'); + $event->set_effective_pass(1); + } + + return $event; +}); + +ok(0, "Second"); +diag "should be a note"; + +test2_stack->top->unfilter($filter); + +ok(1, "Third"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/Formatter.t b/dist/Test-Simple/t/Test2/behavior/Formatter.t new file mode 100644 index 00000000000..f38b022ebe2 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/Formatter.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/intercept run_subtest test2_stack/; +use Test2::Event::Bail; + +{ + + package Formatter::Subclass; + use base 'Test2::Formatter'; + use Test2::Util::HashBase qw{f t}; + + sub init { + my $self = shift; + $self->{+F} = []; + $self->{+T} = []; + } + + sub write { } + sub hide_buffered { 1 } + + sub terminate { + my $s = shift; + push @{$s->{+T}}, [@_]; + } + + sub finalize { + my $s = shift; + push @{$s->{+F}}, [@_]; + } +} + +{ + my $f = Formatter::Subclass->new; + intercept { + my $hub = test2_stack->top; + $hub->format($f); + is(1, 1, 'test event 1'); + is(2, 2, 'test event 2'); + is(3, 2, 'test event 3'); + done_testing; + }; + + is(scalar @{$f->f}, 1, 'finalize method was called on formatter'); + is_deeply( + $f->f->[0], + [3, 3, 1, 0, 0], + 'finalize method received expected arguments' + ); + + ok(!@{$f->t}, 'terminate method was not called on formatter'); +} + +{ + my $f = Formatter::Subclass->new; + + intercept { + my $hub = test2_stack->top; + $hub->format($f); + $hub->send(Test2::Event::Bail->new(reason => 'everything is terrible')); + done_testing; + }; + + is(scalar @{$f->t}, 1, 'terminate method was called because of bail event'); + ok(!@{$f->f}, 'finalize method was not called on formatter'); +} + +{ + my $f = Formatter::Subclass->new; + + intercept { + my $hub = test2_stack->top; + $hub->format($f); + $hub->send(Test2::Event::Plan->new(directive => 'skip_all', reason => 'Skipping all the tests')); + done_testing; + }; + + is(scalar @{$f->t}, 1, 'terminate method was called because of plan skip_all event'); + ok(!@{$f->f}, 'finalize method was not called on formatter'); +} + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/Subtest_buffer_formatter.t b/dist/Test-Simple/t/Test2/behavior/Subtest_buffer_formatter.t new file mode 100644 index 00000000000..fadebf49295 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/Subtest_buffer_formatter.t @@ -0,0 +1,96 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/run_subtest intercept test2_stack/; + +{ + package Formatter::Hide; + sub write { } + sub hide_buffered { 1 } + sub terminate { } + sub finalize { } + + package Formatter::Show; + sub write { } + sub hide_buffered { 0 } + sub terminate { } + sub finalize { } + + package Formatter::NA; + sub write { } + sub terminate { } + sub finalize { } +} + +my %HAS_FORMATTER; + +my $events = intercept { + my $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{unbuffered_none} = $hub->format ? 1 : 0; + }; + run_subtest('unbuffered', $code); + + $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{buffered_none} = $hub->format ? 1 : 0; + }; + run_subtest('buffered', $code, 'BUFFERED'); + + + ##################### + test2_stack->top->format(bless {}, 'Formatter::Hide'); + $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{unbuffered_hide} = $hub->format ? 1 : 0; + }; + run_subtest('unbuffered', $code); + + $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{buffered_hide} = $hub->format ? 1 : 0; + }; + run_subtest('buffered', $code, 'BUFFERED'); + + + ##################### + test2_stack->top->format(bless {}, 'Formatter::Show'); + $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{unbuffered_show} = $hub->format ? 1 : 0; + }; + run_subtest('unbuffered', $code); + + $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{buffered_show} = $hub->format ? 1 : 0; + }; + run_subtest('buffered', $code, 'BUFFERED'); + + + ##################### + $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{unbuffered_na} = $hub->format ? 1 : 0; + }; + run_subtest('unbuffered', $code); + + test2_stack->top->format(bless {}, 'Formatter::NA'); + $code = sub { + my $hub = test2_stack->top; + $HAS_FORMATTER{buffered_na} = $hub->format ? 1 : 0; + }; + run_subtest('buffered', $code, 'BUFFERED'); +}; + +ok(!$HAS_FORMATTER{unbuffered_none}, "Unbuffered with no parent formatter has no formatter"); +ok( $HAS_FORMATTER{unbuffered_show}, "Unbuffered where parent has 'show' formatter has formatter"); +ok( $HAS_FORMATTER{unbuffered_hide}, "Unbuffered where parent has 'hide' formatter has formatter"); + +ok(!$HAS_FORMATTER{buffered_none}, "Buffered with no parent formatter has no formatter"); +ok( $HAS_FORMATTER{buffered_show}, "Buffered where parent has 'show' formatter has formatter"); +ok(!$HAS_FORMATTER{buffered_hide}, "Buffered where parent has 'hide' formatter has no formatter"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/Subtest_events.t b/dist/Test-Simple/t/Test2/behavior/Subtest_events.t new file mode 100644 index 00000000000..2d1dade0a6c --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/Subtest_events.t @@ -0,0 +1,17 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/run_subtest intercept/; + +my $events = intercept { + my $code = sub { ok(1) }; + run_subtest('blah', $code, 'buffered'); +}; + +ok(!$events->[0]->in_subtest, "main event is not inside a subtest"); +ok($events->[0]->subtest_id, "Got subtest id"); +ok($events->[0]->subevents->[0]->in_subtest, "nested events are in the subtest"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/Subtest_plan.t b/dist/Test-Simple/t/Test2/behavior/Subtest_plan.t new file mode 100644 index 00000000000..f16f7c48030 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/Subtest_plan.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/run_subtest intercept/; + +my $events = intercept { + my $code = sub { plan 4; ok(1) }; + run_subtest('bad_plan', $code, 'buffered'); +}; + +is( + $events->[-1]->message, + "Bad subtest plan, expected 4 but ran 1", + "Helpful message if subtest has a bad plan", +); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/Subtest_todo.t b/dist/Test-Simple/t/Test2/behavior/Subtest_todo.t new file mode 100644 index 00000000000..cafc712c626 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/Subtest_todo.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/run_subtest intercept/; + +my $events = intercept { + todo 'testing todo', sub { + run_subtest( + 'fails in todo', + sub { + ok(1, 'first passes'); + ok(0, 'second fails'); + }); + }; +}; + +ok($events->[1], 'Test2::Event::Subtest', 'subtest ran'); +ok($events->[1]->effective_pass, 'Test2::Event::Subtest', 'subtest effective_pass is true'); +ok($events->[1]->todo, 'testing todo', 'subtest todo is set to expected value'); +my @oks = grep { $_->isa('Test2::Event::Ok') } @{$events->[1]->subevents}; +is(scalar @oks, 2, 'got 2 Ok events in the subtest'); +ok($oks[0]->pass, 'first event passed'); +ok($oks[0]->effective_pass, 'first event effective_pass is true'); +ok(!$oks[1]->pass, 'second event failed'); +ok($oks[1]->effective_pass, 'second event effective_pass is true'); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/Taint.t b/dist/Test-Simple/t/Test2/behavior/Taint.t new file mode 100644 index 00000000000..5af92986832 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/Taint.t @@ -0,0 +1,23 @@ +#!/usr/bin/env perl -T +# HARNESS-NO-FORMATTER + +use Test2::API qw/context/; + +sub ok($;$@) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; + return $bool ? 1 : 0; +} + +sub done_testing { + my $ctx = context(); + $ctx->hub->finalize($ctx->trace, 1); + $ctx->release; +} + +ok(1); +ok(1); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/err_var.t b/dist/Test-Simple/t/Test2/behavior/err_var.t new file mode 100644 index 00000000000..1e1bfef39ed --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/err_var.t @@ -0,0 +1,15 @@ +use strict; +use warnings; + +use Test2::IPC; + +use Test2::Tools::Tiny; + +{ + local $! = 100; + + is(0 + $!, 100, 'set $!'); + is(0 + $!, 100, 'preserved $!'); +} + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/init_croak.t b/dist/Test-Simple/t/Test2/behavior/init_croak.t new file mode 100644 index 00000000000..dc492831937 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/init_croak.t @@ -0,0 +1,28 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +BEGIN { + package Foo::Bar; + use Test2::Util::HashBase qw/foo bar baz/; + use Carp qw/croak/; + + sub init { + my $self = shift; + croak "'foo' is a required attribute" + unless $self->{+FOO}; + } +} + +$@ = ""; +my ($file, $line) = (__FILE__, __LINE__ + 1); +eval { my $one = Foo::Bar->new }; +my $err = $@; + +like( + $err, + qr/^'foo' is a required attribute at \Q$file\E line $line/, + "Croak does not report to HashBase from init" +); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/nested_context_exception.t b/dist/Test-Simple/t/Test2/behavior/nested_context_exception.t new file mode 100644 index 00000000000..55db247f4af --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/nested_context_exception.t @@ -0,0 +1,111 @@ +use strict; +use warnings; +BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 } +use Test2::Tools::Tiny; + +use Test2::API qw/context/; + +sub outer { + my $code = shift; + my $ctx = context(); + + $ctx->note("outer"); + + my $out = eval { $code->() }; + + $ctx->release; + + return $out; +} + +sub dies { + my $ctx = context(); + $ctx->note("dies"); + die "Foo"; +} + +sub bad_store { + my $ctx = context(); + $ctx->note("bad store"); + return $ctx; # Emulate storing it somewhere +} + +sub bad_simple { + my $ctx = context(); + $ctx->note("bad simple"); + return; +} + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings => @_ }; + eval { dies() }; +} +ok(!@warnings, "no warnings") || diag @warnings; + +@warnings = (); +my $keep = bad_store(); +eval { my $x = 1 }; # Ensure an eval changing $@ does not meddle. +{ + local $SIG{__WARN__} = sub { push @warnings => @_ }; + ok(1, "random event"); +} +ok(@warnings, "got warnings"); +like( + $warnings[0], + qr/context\(\) was called to retrieve an existing context/, + "got expected warning" +); +$keep = undef; + +{ + @warnings = (); + local $SIG{__WARN__} = sub { push @warnings => @_ }; + bad_simple(); +} +ok(@warnings, "got warnings"); +like( + $warnings[0], + qr/A context appears to have been destroyed without first calling release/, + "got expected warning" +); + +@warnings = (); +outer(\&dies); +{ + local $SIG{__WARN__} = sub { push @warnings => @_ }; + ok(1, "random event"); +} +ok(!@warnings, "no warnings") || diag @warnings; + + + +@warnings = (); +{ + local $SIG{__WARN__} = sub { push @warnings => @_ }; + outer(\&bad_store); +} +ok(@warnings, "got warnings"); +like( + $warnings[0], + qr/A context appears to have been destroyed without first calling release/, + "got expected warning" +); + + + +{ + @warnings = (); + local $SIG{__WARN__} = sub { push @warnings => @_ }; + outer(\&bad_simple); +} +ok(@warnings, "got warnings") || diag @warnings; +like( + $warnings[0], + qr/A context appears to have been destroyed without first calling release/, + "got expected warning" +); + + + +done_testing; diff --git a/dist/Test-Simple/t/Test2/behavior/no_load_api.t b/dist/Test-Simple/t/Test2/behavior/no_load_api.t new file mode 100644 index 00000000000..8e01e409ea0 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/no_load_api.t @@ -0,0 +1,50 @@ +# HARNESS-NO-PRELOAD +use strict; +use warnings; +use Data::Dumper; + +############################################################################### +# # +# This test is to insure certain objects do not load Test2::API directly or # +# indirectly when being required. It is ok for import() to load Test2::API if # +# necessary, but simply requiring the modules should not. # +# # +############################################################################### + +require Test2::Formatter; +require Test2::Formatter::TAP; + +require Test2::Event; +require Test2::Event::Bail; +require Test2::Event::Diag; +require Test2::Event::Exception; +require Test2::Event::Note; +require Test2::Event::Ok; +require Test2::Event::Plan; +require Test2::Event::Skip; +require Test2::Event::Subtest; +require Test2::Event::Waiting; + +require Test2::Util; +require Test2::Util::ExternalMeta; +require Test2::Util::HashBase; +require Test2::Util::Trace; + +require Test2::Hub; +require Test2::Hub::Interceptor; +require Test2::Hub::Subtest; +require Test2::Hub::Interceptor::Terminator; + +my @loaded = grep { $INC{$_} } qw{ + Test2/API.pm + Test2/API/Instance.pm + Test2/API/Context.pm + Test2/API/Stack.pm +}; + +require Test2::Tools::Tiny; + +Test2::Tools::Tiny::ok(!@loaded, "Test2::API was not loaded") + || diag("Loaded: " . Dumper(\@loaded)); + +Test2::Tools::Tiny::done_testing(); diff --git a/dist/Test-Simple/t/Test2/behavior/run_subtest_inherit.t b/dist/Test-Simple/t/Test2/behavior/run_subtest_inherit.t new file mode 100644 index 00000000000..5a79ee412d9 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/run_subtest_inherit.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/run_subtest intercept context/; + +# Test a subtest that should inherit the trace from the tool that calls it +my ($file, $line) = (__FILE__, __LINE__ + 1); +my $events = intercept { my_tool_inherit() }; + +is(@$events, 1, "got 1 event"); +my $e = shift @$events; +ok($e->isa('Test2::Event::Subtest'), "got a subtest event"); +is($e->trace->file, $file, "subtest is at correct file"); +is($e->trace->line, $line, "subtest is at correct line"); +my $plan = pop @{$e->subevents}; +ok($plan->isa('Test2::Event::Plan'), "Removed plan"); +for my $se (@{$e->subevents}) { + is($se->trace->file, $file, "subtest event ($se->{name}) is at correct file"); + is($se->trace->line, $line, "subtest event ($se->{name}) is at correct line"); + ok($se->pass, "subtest event ($se->{name}) passed"); +} + + + + +# Test a subtest that should NOT inherit the trace from the tool that calls it +($file, $line) = (__FILE__, __LINE__ + 1); +$events = intercept { my_tool_no_inherit() }; + +is(@$events, 1, "got 1 event"); +$e = shift @$events; +ok($e->isa('Test2::Event::Subtest'), "got a subtest event"); +is($e->trace->file, $file, "subtest is at correct file"); +is($e->trace->line, $line, "subtest is at correct line"); +$plan = pop @{$e->subevents}; +ok($plan->isa('Test2::Event::Plan'), "Removed plan"); +for my $se (@{$e->subevents}) { + ok($se->trace->file ne $file, "subtest event ($se->{name}) is not in our file"); + ok($se->trace->line ne $line, "subtest event ($se->{name}) is not on our line"); + ok($se->pass, "subtest event ($se->{name}) passed"); +} + +done_testing; + +# Make these tools appear to be in a different file/line +#line 100 'fake.pm' + +sub my_tool_inherit { + my $ctx = context(); + + run_subtest( + 'foo', + sub { + ok(1, 'a'); + ok(2, 'b'); + is_deeply(\@_, [qw/arg1 arg2/], "got args"); + }, + {buffered => 1, inherit_trace => 1}, + 'arg1', 'arg2' + ); + + $ctx->release; +} + +sub my_tool_no_inherit { + my $ctx = context(); + + run_subtest( + 'foo', + sub { + ok(1, 'a'); + ok(2, 'b'); + is_deeply(\@_, [qw/arg1 arg2/], "got args"); + }, + {buffered => 1, inherit_trace => 0}, + 'arg1', 'arg2' + ); + + $ctx->release; +} + + diff --git a/dist/Test-Simple/t/Test2/behavior/special_names.t b/dist/Test-Simple/t/Test2/behavior/special_names.t new file mode 100644 index 00000000000..4cf10e5f964 --- /dev/null +++ b/dist/Test-Simple/t/Test2/behavior/special_names.t @@ -0,0 +1,86 @@ +use strict; +use warnings; +# HARNESS-NO-FORMATTER + +use Test2::Tools::Tiny; + +######################### +# +# This test us here to insure that Ok renders the way we want +# +######################### + +use Test2::API qw/test2_stack/; + +# Ensure the top hub is generated +test2_stack->top; + +my $temp_hub = test2_stack->new_hub(); + +my $ok = capture { + ok(1); + ok(1, ""); + ok(1, " "); + ok(1, "A"); + ok(1, "\n"); + ok(1, "\nB"); + ok(1, "C\n"); + ok(1, "\nD\n"); + ok(1, "E\n\n"); +}; + +my $not_ok = capture { + ok(0); + ok(0, ""); + ok(0, " "); + ok(0, "A"); + ok(0, "\n"); + ok(0, "\nB"); + ok(0, "C\n"); + ok(0, "\nD\n"); + ok(0, "E\n\n"); +}; + +test2_stack->pop($temp_hub); + +is($ok->{STDERR}, "", "STDERR for ok is empty"); +is($ok->{STDOUT}, <{STDOUT}, <[0]->trace->signature; +my $sigfail = $events->[1]->trace->signature; + +ok($sigpass ne $sigfail, "Each tool got a new signature"); + +is($events->[$_]->trace->signature, $sigfail, "Diags share failed ok's signature") for 2 .. $#$events; + +like($sigpass, qr/^C\d+:$$:\Q${ \get_tid() }:${ \__FILE__ }:$line\E$/, "signature is sane"); + +my $trace = Test2::Util::Trace->new(frame => ['main', 'foo.t', 42, 'xxx']); +like( + $trace->signature, + qr/^T\d+:$$:\Q${ \get_tid() }\E:foo\.t:42$/, + "signature uses T when not made via a context" +); + +is($events->[0]->related($events->[1]), 0, "event 0 is not related to event 1"); +is($events->[1]->related($events->[2]), 1, "event 1 is related to event 2"); + +my $e = Test2::Event::Ok->new(pass => 1); +is($e->related($events->[0]), undef, "Cannot check relation, invalid trace"); + +$e = Test2::Event::Ok->new(pass => 1, trace => Test2::Util::Trace->new(frame => ['', '', '', ''])); +is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); + +$e = Test2::Event::Ok->new(pass => 1, trace => Test2::Util::Trace->new(frame => [])); +is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/legacy/TAP.t b/dist/Test-Simple/t/Test2/legacy/TAP.t new file mode 100644 index 00000000000..e58a5ff1fbc --- /dev/null +++ b/dist/Test-Simple/t/Test2/legacy/TAP.t @@ -0,0 +1,147 @@ +use strict; +use warnings; +# HARNESS-NO-FORMATTER + +use Test2::Tools::Tiny; + +######################### +# +# This test us here to insure that Ok, Diag, and Note events render the way +# Test::More renders them, trailing whitespace and all. +# +######################### + +use Test2::API qw/test2_stack context/; +use Test::Builder::Formatter; + +# The tools in Test2::Tools::Tiny have some intentional differences from the +# Test::More versions, these behave more like Test::More which is important for +# back-compat. +sub tm_ok($;$) { + my ($bool, $name) = @_; + my $ctx = context; + + my $ok = bless { + pass => $bool, + name => $name, + effective_pass => 1, + trace => $ctx->trace->snapshot, + }, 'Test2::Event::Ok'; + # Do not call init + + $ctx->hub->send($ok); + + $ctx->release; + return $bool; +} + +# Test::More actually does a bit more, but for this test we just want to see +# what happens when message is a specific string, or undef. +sub tm_diag { + my $ctx = context(); + $ctx->diag(@_); + $ctx->release; +} + +sub tm_note { + my $ctx = context(); + $ctx->note(@_); + $ctx->release; +} + +# Ensure the top hub is generated +test2_stack->top; + +my $temp_hub = test2_stack->new_hub(); +my $diag = capture { + tm_diag(undef); + tm_diag(""); + tm_diag(" "); + tm_diag("A"); + tm_diag("\n"); + tm_diag("\nB"); + tm_diag("C\n"); + tm_diag("\nD\n"); + tm_diag("E\n\n"); +}; + +my $note = capture { + tm_note(undef); + tm_note(""); + tm_note(" "); + tm_note("A"); + tm_note("\n"); + tm_note("\nB"); + tm_note("C\n"); + tm_note("\nD\n"); + tm_note("E\n\n"); +}; + +my $ok = capture { + tm_ok(1); + tm_ok(1, ""); + tm_ok(1, " "); + tm_ok(1, "A"); + tm_ok(1, "\n"); + tm_ok(1, "\nB"); + tm_ok(1, "C\n"); + tm_ok(1, "\nD\n"); + tm_ok(1, "E\n\n"); +}; +test2_stack->pop($temp_hub); + +is($diag->{STDOUT}, "", "STDOUT is empty for diag"); +is($diag->{STDERR}, <{STDERR}, "", "STDERR for note is empty"); +is($note->{STDOUT}, <{STDERR}, "", "STDERR for ok is empty"); +is($ok->{STDOUT}, <can($_), "$_ method is present") for qw{ + context_do + no_context + + test2_init_done + test2_load_done + + test2_pid + test2_tid + test2_stack + test2_no_wait + + test2_add_callback_context_init + test2_add_callback_context_release + test2_add_callback_exit + test2_add_callback_post_load + test2_list_context_init_callbacks + test2_list_context_release_callbacks + test2_list_exit_callbacks + test2_list_post_load_callbacks + + test2_ipc + test2_ipc_drivers + test2_ipc_add_driver + test2_ipc_polling + test2_ipc_disable_polling + test2_ipc_enable_polling + + test2_formatter + test2_formatters + test2_formatter_add + test2_formatter_set +}; + +ok(!$LOADED, "Was not load_done right away"); +ok(!$INIT, "Init was not done right away"); +ok(Test2::API::test2_load_done, "We loaded it"); + +# Note: This is a check that stuff happens in an END block. +{ + { + package FOLLOW; + + sub DESTROY { + return if $_[0]->{fixed}; + print "not ok - Did not run end ($_[0]->{name})!"; + $? = 255; + exit 255; + } + } + + our $kill1 = bless {fixed => 0, name => "Custom Hook"}, 'FOLLOW'; + Test2::API::test2_add_callback_exit( + sub { + print "# Running END hook\n"; + $kill1->{fixed} = 1; + } + ); + + our $kill2 = bless {fixed => 0, name => "set exit"}, 'FOLLOW'; + my $old = Test2::API::Instance->can('set_exit'); + no warnings 'redefine'; + *Test2::API::Instance::set_exit = sub { + $kill2->{fixed} = 1; + print "# Running set_exit\n"; + $old->(@_); + }; +} + +ok($CLASS->can('test2_init_done')->(), "init is done."); +ok($CLASS->can('test2_load_done')->(), "Test2 is finished loading"); + +is($CLASS->can('test2_pid')->(), $$, "got pid"); +is($CLASS->can('test2_tid')->(), get_tid(), "got tid"); + +ok($CLASS->can('test2_stack')->(), 'got stack'); +is($CLASS->can('test2_stack')->(), $CLASS->can('test2_stack')->(), "always get the same stack"); + +ok($CLASS->can('test2_ipc')->(), 'got ipc'); +is($CLASS->can('test2_ipc')->(), $CLASS->can('test2_ipc')->(), "always get the same IPC"); + +is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/Test2::IPC::Driver::Files/], "Got driver list"); + +# Verify it reports to the correct file/line, there was some trouble with this... +my $file = __FILE__; +my $line = __LINE__ + 1; +my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') }; +like( + $warnings->[0], + qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line}, + "got warning about adding driver too late" +); + +is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list"); + +ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); +$CLASS->can('test2_ipc_disable_polling')->(); +ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off"); +$CLASS->can('test2_ipc_enable_polling')->(); +ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); + +ok($CLASS->can('test2_formatter')->(), "Got a formatter"); +is($CLASS->can('test2_formatter')->(), $CLASS->can('test2_formatter')->(), "always get the same Formatter (class name)"); + +my $ran = 0; +$CLASS->can('test2_add_callback_post_load')->(sub { $ran++ }); +is($ran, 1, "ran the post-load"); + +like( + exception { $CLASS->can('test2_formatter_set')->() }, + qr/No formatter specified/, + "formatter_set requires an argument" +); + +like( + exception { $CLASS->can('test2_formatter_set')->('fake') }, + qr/Global Formatter already set/, + "formatter_set doesn't work after initialization", +); + +ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); +$CLASS->can('test2_no_wait')->(1); +ok($CLASS->can('test2_no_wait')->(), "no_wait is set"); +$CLASS->can('test2_no_wait')->(undef); +ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); + +my $pctx; +sub tool_a($;$) { + Test2::API::context_do { + my $ctx = shift; + my ($bool, $name) = @_; + $pctx = wantarray; + die "xyz" unless $bool; + $ctx->ok($bool, $name); + return unless defined $pctx; + return (1, 2) if $pctx; + return 'a'; + } @_; +} + +$pctx = 'x'; +tool_a(1, "void context test"); +ok(!defined($pctx), "void context"); + +my $x = tool_a(1, "scalar context test"); +ok(defined($pctx) && $pctx == 0, "scalar context"); +is($x, 'a', "got scalar return"); + +my @x = tool_a(1, "array context test"); +ok($pctx, "array context"); +is_deeply(\@x, [1, 2], "Got array return"); + +like( + exception { tool_a(0) }, + qr/^xyz/, + "got exception" +); + +sub { + my $outer = context(); + sub { + my $middle = context(); + is($outer->trace, $middle->trace, "got the same context before calling no_context"); + + Test2::API::no_context { + my $inner = context(); + ok($inner->trace != $outer->trace, "Got a different context inside of no_context()"); + $inner->release; + }; + + $middle->release; + }->(); + + $outer->release; +}->(); + +sub { + my $outer = context(); + sub { + my $middle = context(); + is($outer->trace, $middle->trace, "got the same context before calling no_context"); + + Test2::API::no_context { + my $inner = context(); + ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); + $inner->release; + } $outer->hub->hid; + + $middle->release; + }->(); + + $outer->release; +}->(); + +sub { + my @warnings; + my $outer = context(); + sub { + my $middle = context(); + is($outer->trace, $middle->trace, "got the same context before calling no_context"); + + local $SIG{__WARN__} = sub { push @warnings => @_ }; + Test2::API::no_context { + my $inner = context(); + ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); + } $outer->hub->hid; + + $middle->release; + }->(); + + $outer->release; + + is(@warnings, 1, "1 warning"); + like( + $warnings[0], + qr/A context appears to have been destroyed without first calling release/, + "Got warning about unreleased context" + ); +}->(); + + +sub { + my $hub = Test2::Hub->new(); + my $ctx = context(hub => $hub); + is($ctx->hub,$hub, 'got the hub of context() argument'); + $ctx->release; +}->(); + + +my $sub = sub { }; + +Test2::API::test2_add_callback_context_acquire($sub); +Test2::API::test2_add_callback_context_init($sub); +Test2::API::test2_add_callback_context_release($sub); +Test2::API::test2_add_callback_exit($sub); +Test2::API::test2_add_callback_post_load($sub); + +is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 1, "got the one instance of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 1, "got the one instance of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 1, "got the one instance of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 1, "got the one instance of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 1, "got the one instance of the hook"); + +Test2::API::test2_add_callback_context_acquire($sub); +Test2::API::test2_add_callback_context_init($sub); +Test2::API::test2_add_callback_context_release($sub); +Test2::API::test2_add_callback_exit($sub); +Test2::API::test2_add_callback_post_load($sub); + +is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 2, "got the two instances of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 2, "got the two instances of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, "got the two instances of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 2, "got the two instances of the hook"); +is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 2, "got the two instances of the hook"); + +done_testing; + diff --git a/dist/Test-Simple/t/Test2/modules/API/Breakage.t b/dist/Test-Simple/t/Test2/modules/API/Breakage.t new file mode 100644 index 00000000000..e2932469f38 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/API/Breakage.t @@ -0,0 +1,89 @@ +use strict; +use warnings; + +use Test2::IPC; +use Test2::Tools::Tiny; +use Test2::API::Breakage; +my $CLASS = 'Test2::API::Breakage'; + +for my $meth (qw/upgrade_suggested upgrade_required known_broken/) { + my @list = $CLASS->$meth; + ok(!(@list % 2), "Got even list ($meth)"); + ok(!(grep {!defined($_)} @list), "No undefined items ($meth)"); +} + +{ + no warnings 'redefine'; + local *Test2::API::Breakage::upgrade_suggested = sub { + return ('T2Test::UG1' => '1.0', 'T2Test::UG2' => '0.5'); + }; + + local *Test2::API::Breakage::upgrade_required = sub { + return ('T2Test::UR1' => '1.0', 'T2Test::UR2' => '0.5'); + }; + + local *Test2::API::Breakage::known_broken = sub { + return ('T2Test::KB1' => '1.0', 'T2Test::KB2' => '0.5'); + }; + use warnings 'redefine'; + + ok(!$CLASS->report, "Nothing to report"); + ok(!$CLASS->report(1), "Still nothing to report"); + + { + local %INC = ( + %INC, + 'T2Test/UG1.pm' => 1, + 'T2Test/UG2.pm' => 1, + 'T2Test/UR1.pm' => 1, + 'T2Test/UR2.pm' => 1, + 'T2Test/KB1.pm' => 1, + 'T2Test/KB2.pm' => 1, + ); + local $T2Test::UG1::VERSION = '0.9'; + local $T2Test::UG2::VERSION = '0.9'; + local $T2Test::UR1::VERSION = '0.9'; + local $T2Test::UR2::VERSION = '0.9'; + local $T2Test::KB1::VERSION = '0.9'; + local $T2Test::KB2::VERSION = '0.9'; + + my @report = $CLASS->report; + + is_deeply( + [sort @report], + [ + sort + " * Module 'T2Test::UG1' is outdated, we recommed updating above 1.0.", + " * Module 'T2Test::UR1' is outdated and known to be broken, please update to 1.0 or higher.", + " * Module 'T2Test::KB1' is known to be broken in version 1.0 and below, newer versions have not been tested. You have: 0.9", + " * Module 'T2Test::KB2' is known to be broken in version 0.5 and below, newer versions have not been tested. You have: 0.9", + ], + "Got expected report items" + ); + } + + my %look; + unshift @INC => sub { + my ($this, $file) = @_; + $look{$file}++ if $file =~ m{T2Test}; + return; + }; + ok(!$CLASS->report, "Nothing to report"); + is_deeply(\%look, {}, "Did not try to load anything"); + + ok(!$CLASS->report(1), "Nothing to report"); + is_deeply( + \%look, + { + 'T2Test/UG1.pm' => 1, + 'T2Test/UG2.pm' => 1, + 'T2Test/UR1.pm' => 1, + 'T2Test/UR2.pm' => 1, + 'T2Test/KB1.pm' => 1, + 'T2Test/KB2.pm' => 1, + }, + "Tried to load modules" + ); +} + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/API/Context.t b/dist/Test-Simple/t/Test2/modules/API/Context.t new file mode 100644 index 00000000000..c0dbfc93ea8 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/API/Context.t @@ -0,0 +1,462 @@ +use strict; +use warnings; + +BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 } +use Test2::Tools::Tiny; + +use Test2::API qw{ + context intercept + test2_stack + test2_add_callback_context_acquire + test2_add_callback_context_init + test2_add_callback_context_release +}; + +my $error = exception { context(); 1 }; +my $exception = "context() called, but return value is ignored at " . __FILE__ . ' line ' . (__LINE__ - 1); +like($error, qr/^\Q$exception\E/, "Got the exception" ); + +my $ref; +my $frame; +sub wrap(&) { + my $ctx = context(); + my ($pkg, $file, $line, $sub) = caller(0); + $frame = [$pkg, $file, $line, $sub]; + + $_[0]->($ctx); + + $ref = "$ctx"; + + $ctx->release; +} + +wrap { + my $ctx = shift; + ok($ctx->hub, "got hub"); + delete $ctx->trace->frame->[4]; + is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); +}; + +wrap { + my $ctx = shift; + ok("$ctx" ne "$ref", "Got a new context"); + my $new = context(); + my @caller = caller(0); + is_deeply( + $new, + {%$ctx, _is_canon => undef, _is_spawn => [@caller[0,1,2,3]]}, + "Additional call to context gets spawn" + ); + delete $ctx->trace->frame->[4]; + is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); + $new->release; +}; + +wrap { + my $ctx = shift; + my $snap = $ctx->snapshot; + + is_deeply( + $snap, + {%$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef}, + "snapshot is identical except for canon/spawn/aborted" + ); + ok($ctx != $snap, "snapshot is a new instance"); +}; + +my $end_ctx; +{ # Simulate an END block... + local *END = sub { local *__ANON__ = 'END'; context() }; + my $ctx = END(); + $frame = [ __PACKAGE__, __FILE__, __LINE__ - 1, 'main::END' ]; + # "__LINE__ - 1" on the preceding line forces the value to be an IV + # (even though __LINE__ on its own is a PV), just as (caller)[2] is. + $end_ctx = $ctx->snapshot; + $ctx->release; +} +delete $end_ctx->trace->frame->[4]; +is_deeply( $end_ctx->trace->frame, $frame, 'context is ok in an end block'); + +# Test event generation +{ + package My::Formatter; + + sub write { + my $self = shift; + my ($e) = @_; + push @$self => $e; + } +} +my $events = bless [], 'My::Formatter'; +my $hub = Test2::Hub->new( + formatter => $events, +); +my $trace = Test2::Util::Trace->new( + frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ], +); +my $ctx = Test2::API::Context->new( + trace => $trace, + hub => $hub, +); + +my $e = $ctx->build_event('Ok', pass => 1, name => 'foo'); +is($e->pass, 1, "Pass"); +is($e->name, 'foo', "got name"); +is_deeply($e->trace, $trace, "Got the trace info"); +ok(!@$events, "No events yet"); + +$e = $ctx->send_event('Ok', pass => 1, name => 'foo'); +is($e->pass, 1, "Pass"); +is($e->name, 'foo', "got name"); +is_deeply($e->trace, $trace, "Got the trace info"); +is(@$events, 1, "1 event"); +is_deeply($events, [$e], "Hub saw the event"); +pop @$events; + +$e = $ctx->ok(1, 'foo'); +is($e->pass, 1, "Pass"); +is($e->name, 'foo', "got name"); +is_deeply($e->trace, $trace, "Got the trace info"); +is(@$events, 1, "1 event"); +is_deeply($events, [$e], "Hub saw the event"); +pop @$events; + +$e = $ctx->note('foo'); +is($e->message, 'foo', "got message"); +is_deeply($e->trace, $trace, "Got the trace info"); +is(@$events, 1, "1 event"); +is_deeply($events, [$e], "Hub saw the event"); +pop @$events; + +$e = $ctx->diag('foo'); +is($e->message, 'foo', "got message"); +is_deeply($e->trace, $trace, "Got the trace info"); +is(@$events, 1, "1 event"); +is_deeply($events, [$e], "Hub saw the event"); +pop @$events; + +$e = $ctx->plan(100); +is($e->max, 100, "got max"); +is_deeply($e->trace, $trace, "Got the trace info"); +is(@$events, 1, "1 event"); +is_deeply($events, [$e], "Hub saw the event"); +pop @$events; + +$e = $ctx->skip('foo', 'because'); +is($e->name, 'foo', "got name"); +is($e->reason, 'because', "got reason"); +ok($e->pass, "skip events pass by default"); +is_deeply($e->trace, $trace, "Got the trace info"); +is(@$events, 1, "1 event"); +is_deeply($events, [$e], "Hub saw the event"); +pop @$events; + +$e = $ctx->skip('foo', 'because', pass => 0); +ok(!$e->pass, "can override skip params"); +pop @$events; + +# Test hooks + +my @hooks; +$hub = test2_stack()->top; +my $ref1 = $hub->add_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_init' }); +my $ref2 = $hub->add_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_release' }); +test2_add_callback_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_init' }); +test2_add_callback_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_release' }); + +my $ref3 = $hub->add_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'hub_acquire' }); +test2_add_callback_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'global_acquire' }); + +sub { + push @hooks => 'start'; + my $ctx = context(on_init => sub { push @hooks => 'ctx_init' }, on_release => sub { push @hooks => 'ctx_release' }); + push @hooks => 'deep'; + my $ctx2 = sub { + context(on_init => sub { push @hooks => 'ctx_init_deep' }, on_release => sub { push @hooks => 'ctx_release_deep' }); + }->(); + push @hooks => 'release_deep'; + $ctx2->release; + push @hooks => 'release_parent'; + $ctx->release; + push @hooks => 'released_all'; + + push @hooks => 'new'; + $ctx = context(on_init => sub { push @hooks => 'ctx_init2' }, on_release => sub { push @hooks => 'ctx_release2' }); + push @hooks => 'release_new'; + $ctx->release; + push @hooks => 'done'; +}->(); + +$hub->remove_context_init($ref1); +$hub->remove_context_release($ref2); +$hub->remove_context_acquire($ref3); +@{Test2::API::_context_init_callbacks_ref()} = (); +@{Test2::API::_context_release_callbacks_ref()} = (); +@{Test2::API::_context_acquire_callbacks_ref()} = (); + +is_deeply( + \@hooks, + [qw{ + start + global_acquire + hub_acquire + global_init + hub_init + ctx_init + deep + global_acquire + hub_acquire + release_deep + release_parent + ctx_release_deep + ctx_release + hub_release + global_release + released_all + new + global_acquire + hub_acquire + global_init + hub_init + ctx_init2 + release_new + ctx_release2 + hub_release + global_release + done + }], + "Got all hook in correct order" +); + +{ + my $ctx = context(level => -1); + + my $one = Test2::API::Context->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']), + hub => test2_stack()->top, + ); + is($one->_depth, 0, "default depth"); + + my $ran = 0; + my $doit = sub { + is_deeply(\@_, [qw/foo bar/], "got args"); + $ran++; + die "Make sure old context is restored"; + }; + + eval { $one->do_in_context($doit, 'foo', 'bar') }; + + my $spawn = context(level => -1, wrapped => -2); + is($spawn->trace, $ctx->trace, "Old context restored"); + $spawn->release; + $ctx->release; + + ok(!exception { $one->do_in_context(sub {1}) }, "do_in_context works without an original") +} + +{ + like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace"); + + my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); + like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub"); + + my $hub = test2_stack()->top; + my $ctx = Test2::API::Context->new(trace => $trace, hub => $hub); + is($ctx->{_depth}, 0, "depth set to 0 when not defined."); + + $ctx = Test2::API::Context->new(trace => $trace, hub => $hub, _depth => 1); + is($ctx->{_depth}, 1, "Do not reset depth"); + + like( + exception { $ctx->release }, + qr/release\(\) should not be called on context that is neither canon nor a child/, + "Non canonical context, do not release" + ); +} + +sub { + like( + exception { my $ctx = context(level => 20) }, + qr/Could not find context at depth 21/, + "Level sanity" + ); + + ok( + !exception { + my $ctx = context(level => 20, fudge => 1); + $ctx->release; + }, + "Was able to get context when fudging level" + ); +}->(); + +sub { + my ($ctx1, $ctx2); + sub { $ctx1 = context() }->(); + + my @warnings; + { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $ctx2 = context(); + $ctx1 = undef; + } + + $ctx2->release; + + is(@warnings, 1, "1 warning"); + like( + $warnings[0], + qr/^context\(\) was called to retrieve an existing context, however the existing/, + "Got expected warning" + ); +}->(); + +sub { + my $ctx = context(); + my $e = exception { $ctx->throw('xxx') }; + like($e, qr/xxx/, "got exception"); + + $ctx = context(); + my $warnings = warnings { $ctx->alert('xxx') }; + like($warnings->[0], qr/xxx/, "got warning"); + $ctx->release; +}->(); + +sub { + my $ctx = context; + + is($ctx->_parse_event('Ok'), 'Test2::Event::Ok', "Got the Ok event class"); + is($ctx->_parse_event('+Test2::Event::Ok'), 'Test2::Event::Ok', "Got the +Ok event class"); + + like( + exception { $ctx->_parse_event('+DFASGFSDFGSDGSD') }, + qr/Could not load event module 'DFASGFSDFGSDGSD': Can't locate DFASGFSDFGSDGSD\.pm/, + "Bad event type" + ); +}->(); + +{ + { + package An::Info::Thingy; + sub render { 'zzz' } + } + + my ($e1, $e2); + my $events = intercept { + my $ctx = context(); + $e1 = $ctx->ok(0, 'foo', ['xxx', sub { 'yyy' }, bless({}, 'An::Info::Thingy')]); + $e2 = $ctx->ok(0, 'foo'); + $ctx->release; + }; + + ok($e1->isa('Test2::Event::Ok'), "returned ok event"); + ok($e2->isa('Test2::Event::Ok'), "returned ok event"); + + is($events->[0], $e1, "got ok event 1"); + + is($events->[2]->message, 'xxx', "event 1 diag 2"); + ok($events->[2]->isa('Test2::Event::Diag'), "event 1 diag 2 is diag"); + + is($events->[3]->summary, 'yyy', "event 1 info 1"); + is($events->[3]->diagnostics, 1, "event 1 info 1 is diagnostics"); + ok($events->[3]->isa('Test2::Event::Info'), "event 1 info 1 is an info"); + + is($events->[4]->summary, 'zzz', "event 1 info 2"); + is($events->[4]->diagnostics, 1, "event 1 info 2 is diagnostics"); + ok($events->[4]->isa('Test2::Event::Info'), "event 2 info 1 is an info"); + + is($events->[5], $e2, "got ok event 2"); +} + +sub { + local $! = 100; + local $@ = 'foobarbaz'; + local $? = 123; + + my $ctx = context(); + + is($ctx->errno, 100, "saved errno"); + is($ctx->eval_error, 'foobarbaz', "saved eval error"); + is($ctx->child_error, 123, "saved child exit"); + + $! = 22; + $@ = 'xyz'; + $? = 33; + + is(0 + $!, 22, "altered \$! in tool"); + is($@, 'xyz', "altered \$@ in tool"); + is($?, 33, "altered \$? in tool"); + + sub { + my $ctx2 = context(); + + $! = 42; + $@ = 'app'; + $? = 43; + + is(0 + $!, 42, "altered \$! in tool (nested)"); + is($@, 'app', "altered \$@ in tool (nested)"); + is($?, 43, "altered \$? in tool (nested)"); + + $ctx2->release; + + is(0 + $!, 22, "restored the nested \$! in tool"); + is($@, 'xyz', "restored the nested \$@ in tool"); + is($?, 33, "restored the nested \$? in tool"); + }->(); + + sub { + my $ctx2 = context(); + + $! = 42; + $@ = 'app'; + $? = 43; + + is(0 + $!, 42, "altered \$! in tool (nested)"); + is($@, 'app', "altered \$@ in tool (nested)"); + is($?, 43, "altered \$? in tool (nested)"); + + # Will not warn since $@ is changed + $ctx2 = undef; + + is(0 + $!, 42, 'Destroy does not reset $!'); + is($@, 'app', 'Destroy does not reset $@'); + is($?, 43, 'Destroy does not reset $?'); + }->(); + + $ctx->release; + + is($ctx->errno, 100, "restored errno"); + is($ctx->eval_error, 'foobarbaz', "restored eval error"); + is($ctx->child_error, 123, "restored child exit"); +}->(); + + +sub { + local $! = 100; + local $@ = 'foobarbaz'; + local $? = 123; + + my $ctx = context(); + + is($ctx->errno, 100, "saved errno"); + is($ctx->eval_error, 'foobarbaz', "saved eval error"); + is($ctx->child_error, 123, "saved child exit"); + + $! = 22; + $@ = 'xyz'; + $? = 33; + + is(0 + $!, 22, "altered \$! in tool"); + is($@, 'xyz', "altered \$@ in tool"); + is($?, 33, "altered \$? in tool"); + + # Will not warn since $@ is changed + $ctx = undef; + + is(0 + $!, 22, "Destroy does not restore \$!"); + is($@, 'xyz', "Destroy does not restore \$@"); + is($?, 33, "Destroy does not restore \$?"); +}->(); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/API/Instance.t b/dist/Test-Simple/t/Test2/modules/API/Instance.t new file mode 100644 index 00000000000..9e3e4ccd4de --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/API/Instance.t @@ -0,0 +1,470 @@ +use strict; +use warnings; + +use Test2::IPC; +use Test2::Tools::Tiny; +use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/; + +my $CLASS = 'Test2::API::Instance'; + +my $one = $CLASS->new; +is_deeply( + $one, + { + contexts => {}, + + finalized => undef, + ipc => undef, + formatter => undef, + + ipc_polling => undef, + ipc_drivers => [], + + formatters => [], + + no_wait => 0, + loaded => 0, + + exit_callbacks => [], + post_load_callbacks => [], + context_acquire_callbacks => [], + context_init_callbacks => [], + context_release_callbacks => [], + + stack => [], + }, + "Got initial settings" +); + +%$one = (); +is_deeply($one, {}, "wiped object"); + +$one->reset; +is_deeply( + $one, + { + contexts => {}, + + ipc_polling => undef, + ipc_drivers => [], + + formatters => [], + + finalized => undef, + ipc => undef, + formatter => undef, + + no_wait => 0, + loaded => 0, + + exit_callbacks => [], + post_load_callbacks => [], + context_acquire_callbacks => [], + context_init_callbacks => [], + context_release_callbacks => [], + + stack => [], + }, + "Reset Object" +); + +ok(!$one->formatter_set, "no formatter set"); +$one->set_formatter('Foo'); +ok($one->formatter_set, "formatter set"); +$one->reset; + +my $ran = 0; +my $callback = sub { $ran++ }; +$one->add_post_load_callback($callback); +ok(!$ran, "did not run yet"); +is_deeply($one->post_load_callbacks, [$callback], "stored callback for later"); + +ok(!$one->loaded, "not loaded"); +$one->load; +ok($one->loaded, "loaded"); +is($ran, 1, "ran the callback"); + +$one->load; +is($ran, 1, "Did not run the callback again"); + +$one->add_post_load_callback($callback); +is($ran, 2, "ran the new callback"); +is_deeply($one->post_load_callbacks, [$callback, $callback], "stored callback for the record"); + +like( + exception { $one->add_post_load_callback({}) }, + qr/Post-load callbacks must be coderefs/, + "Post-load callbacks must be coderefs" +); + +$one->reset; +ok($one->ipc, 'got ipc'); +ok($one->finalized, "calling ipc finalized the object"); + +$one->reset; +ok($one->stack, 'got stack'); +ok(!$one->finalized, "calling stack did not finaliz the object"); + +$one->reset; +ok($one->formatter, 'Got formatter'); +ok($one->finalized, "calling format finalized the object"); + +$one->reset; +$one->set_formatter('Foo'); +is($one->formatter, 'Foo', "got specified formatter"); +ok($one->finalized, "calling format finalized the object"); + +{ + local $ENV{T2_FORMATTER} = 'TAP'; + $one->reset; + is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); + ok($one->finalized, "calling format finalized the object"); + + local $ENV{T2_FORMATTER} = '+Test2::Formatter::TAP'; + $one->reset; + is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); + ok($one->finalized, "calling format finalized the object"); + + local $ENV{T2_FORMATTER} = '+Fake'; + $one->reset; + like( + exception { $one->formatter }, + qr/COULD NOT LOAD FORMATTER 'Fake' \(set by the 'T2_FORMATTER' environment variable\)/, + "Bad formatter" + ); +} + +$ran = 0; +$one->reset; +$one->add_exit_callback($callback); +is(@{$one->exit_callbacks}, 1, "added an exit callback"); +$one->add_exit_callback($callback); +is(@{$one->exit_callbacks}, 2, "added another exit callback"); + +like( + exception { $one->add_exit_callback({}) }, + qr/End callbacks must be coderefs/, + "Exit callbacks must be coderefs" +); + +if (CAN_REALLY_FORK) { + $one->reset; + my $pid = fork; + die "Failed to fork!" unless defined $pid; + unless($pid) { exit 0 } + + is($one->_ipc_wait, 0, "No errors"); + + $pid = fork; + die "Failed to fork!" unless defined $pid; + unless($pid) { exit 255 } + my @warnings; + { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + is($one->_ipc_wait, 255, "Process exited badly"); + } + like($warnings[0], qr/Process .* did not exit cleanly \(status: 255\)/, "Warn about exit"); +} + +if (CAN_THREAD && $] ge '5.010') { + require threads; + $one->reset; + + threads->new(sub { 1 }); + is($one->_ipc_wait, 0, "No errors"); + + if (threads->can('error')) { + threads->new(sub { + close(STDERR); + close(STDOUT); + die "xxx" + }); + my @warnings; + { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + is($one->_ipc_wait, 255, "Thread exited badly"); + } + like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit"); + } +} + +{ + $one->reset(); + local $? = 0; + $one->set_exit; + is($?, 0, "no errors on exit"); +} + +{ + $one->reset(); + $one->set__tid(1); + local $? = 0; + $one->set_exit; + is($?, 0, "no errors on exit"); +} + +{ + $one->reset(); + $one->stack->top; + $one->no_wait(1); + local $? = 0; + $one->set_exit; + is($?, 0, "no errors on exit"); +} + +{ + $one->reset(); + $one->stack->top->set_no_ending(1); + local $? = 0; + $one->set_exit; + is($?, 0, "no errors on exit"); +} + +{ + $one->reset(); + $one->load(); + $one->stack->top->set_failed(2); + local $? = 0; + $one->set_exit; + is($?, 2, "number of failures"); +} + +{ + $one->reset(); + $one->load(); + local $? = 500; + $one->set_exit; + is($?, 255, "set exit code to a sane number"); +} + +{ + local %INC = %INC; + delete $INC{'Test2/IPC.pm'}; + $one->reset(); + $one->load(); + my @events; + $one->stack->top->filter(sub { push @events => $_[1]; undef}); + $one->stack->new_hub; + local $? = 0; + $one->set_exit; + is($?, 255, "errors on exit"); + like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); +} + +{ + $one->reset; + my $stderr = ""; + { + local $INC{'Test/Builder.pm'} = __FILE__; + local $Test2::API::VERSION = '0.002'; + local $Test::Builder::VERSION = '0.001'; + local *STDERR; + open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; + + $one->set_exit; + } + + is($stderr, <<' EOT', "Got warning about version mismatch"); + +******************************************************************************** +* * +* Test::Builder -- Test2::API version mismatch detected * +* * +******************************************************************************** + Test2::API Version: 0.002 +Test::Builder Version: 0.001 + +This is not a supported configuration, you will have problems. + + EOT +} + +{ + require Test2::API::Breakage; + no warnings qw/redefine once/; + my $ran = 0; + local *Test2::API::Breakage::report = sub { $ran++; return "foo" }; + use warnings qw/redefine once/; + $one->reset(); + $one->load(); + + my $stderr = ""; + { + local *STDERR; + open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; + local $? = 255; + $one->set_exit; + } + + is($stderr, <<" EOT", "Reported bad modules"); + +You have loaded versions of test modules known to have problems with Test2. +This could explain some test failures. +foo + + EOT +} + + +{ + $one->reset(); + $one->load(); + my @events; + $one->stack->top->filter(sub { push @events => $_[1]; undef}); + $one->stack->new_hub; + ok($one->stack->top->ipc, "Have IPC"); + $one->stack->new_hub; + ok($one->stack->top->ipc, "Have IPC"); + $one->stack->top->set_ipc(undef); + ok(!$one->stack->top->ipc, "no IPC"); + $one->stack->new_hub; + local $? = 0; + $one->set_exit; + is($?, 255, "errors on exit"); + like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); +} + +if (CAN_REALLY_FORK) { + local $SIG{__WARN__} = sub { }; + $one->reset(); + my $pid = fork; + die "Failed to fork!" unless defined $pid; + unless ($pid) { exit 255 } + $one->_finalize; + $one->stack->top; + + local $? = 0; + $one->set_exit; + is($?, 255, "errors on exit"); + + $one->reset(); + $pid = fork; + die "Failed to fork!" unless defined $pid; + unless ($pid) { exit 255 } + $one->_finalize; + $one->stack->top; + + local $? = 122; + $one->set_exit; + is($?, 122, "kept original exit"); +} + +{ + my $ctx = bless { + trace => Test2::Util::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']), + hub => Test2::Hub->new(), + }, 'Test2::API::Context'; + $one->contexts->{1234} = $ctx; + + local $? = 500; + my $warnings = warnings { $one->set_exit }; + is($?, 255, "set exit code to a sane number"); + + is_deeply( + $warnings, + [ + "context object was never released! This means a testing tool is behaving very badly at Foo/Bar.pm line 42.\n" + ], + "Warned about unfreed context" + ); +} + +{ + local %INC = %INC; + delete $INC{'Test2/IPC.pm'}; + delete $INC{'threads.pm'}; + ok(!USE_THREADS, "Sanity Check"); + + $one->reset; + ok(!$one->ipc, 'IPC not loaded, no IPC object'); + ok($one->finalized, "calling ipc finalized the object"); + is($one->ipc_polling, undef, "no polling defined"); + ok(!@{$one->ipc_drivers}, "no driver"); + + if (CAN_THREAD) { + local $INC{'threads.pm'} = 1; + no warnings 'once'; + local *threads::tid = sub { 0 } unless threads->can('tid'); + $one->reset; + ok($one->ipc, 'IPC loaded if threads are'); + ok($one->finalized, "calling ipc finalized the object"); + ok($one->ipc_polling, "polling on by default"); + is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); + } + + { + local $INC{'Test2/IPC.pm'} = 1; + $one->reset; + ok($one->ipc, 'IPC loaded if Test2::IPC is'); + ok($one->finalized, "calling ipc finalized the object"); + ok($one->ipc_polling, "polling on by default"); + is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); + } + + require Test2::IPC::Driver::Files; + $one->reset; + $one->add_ipc_driver('Test2::IPC::Driver::Files'); + ok($one->ipc, 'IPC loaded if drivers have been added'); + ok($one->finalized, "calling ipc finalized the object"); + ok($one->ipc_polling, "polling on by default"); + + my $file = __FILE__; + my $line = __LINE__ + 1; + my $warnings = warnings { $one->add_ipc_driver('Test2::IPC::Driver::Files') }; + like( + $warnings->[0], + qr{^IPC driver Test2::IPC::Driver::Files loaded too late to be used as the global ipc driver at \Q$file\E line $line}, + "Got warning at correct frame" + ); + + $one->reset; + $one->add_ipc_driver('Fake::Fake::XXX'); + is( + exception { $one->ipc }, + "IPC has been requested, but no viable drivers were found. Aborting...\n", + "Failed without viable IPC driver" + ); +} + +{ + $one->reset; + + ok(!@{$one->context_init_callbacks}, "no callbacks"); + is($one->ipc_polling, undef, "no polling, undef"); + + $one->disable_ipc_polling; + ok(!@{$one->context_init_callbacks}, "no callbacks"); + is($one->ipc_polling, undef, "no polling, still undef"); + + my $cull = 0; + no warnings 'once'; + local *Fake::Hub::cull = sub { $cull++ }; + use warnings; + + $one->enable_ipc_polling; + ok(defined($one->{_pid}), "pid is defined"); + ok(defined($one->{_tid}), "tid is defined"); + is(@{$one->context_init_callbacks}, 1, "added the callback"); + is($one->ipc_polling, 1, "polling on"); + $one->set_ipc_shm_last('abc1'); + $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); + is($cull, 1, "called cull once"); + $cull = 0; + + $one->disable_ipc_polling; + is(@{$one->context_init_callbacks}, 1, "kept the callback"); + is($one->ipc_polling, 0, "no polling, set to 0"); + $one->set_ipc_shm_last('abc3'); + $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); + is($cull, 0, "did not call cull"); + $cull = 0; + + $one->enable_ipc_polling; + is(@{$one->context_init_callbacks}, 1, "did not add the callback"); + is($one->ipc_polling, 1, "polling on"); + $one->set_ipc_shm_last('abc3'); + $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); + is($cull, 1, "called cull once"); +} + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/API/Stack.t b/dist/Test-Simple/t/Test2/modules/API/Stack.t new file mode 100644 index 00000000000..c2016e292ed --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/API/Stack.t @@ -0,0 +1,79 @@ +use strict; +use warnings; +use Test2::IPC; +use Test2::Tools::Tiny; +use Test2::API::Stack; +use Test2::API qw/test2_ipc/; + +ok(my $stack = Test2::API::Stack->new, "Create a stack"); + +ok(!@$stack, "Empty stack"); +ok(!$stack->peek, "Nothing to peek at"); + +ok(!exception { $stack->cull }, "cull lives when stack is empty"); +ok(!exception { $stack->all }, "all lives when stack is empty"); +ok(!exception { $stack->clear }, "clear lives when stack is empty"); + +like( + exception { $stack->pop(Test2::Hub->new) }, + qr/No hubs on the stack/, + "No hub to pop" +); + +my $hub = Test2::Hub->new; +ok($stack->push($hub), "pushed a hub"); + +like( + exception { $stack->pop($hub) }, + qr/You cannot pop the root hub/, + "Root hub cannot be popped" +); + +$stack->push($hub); +like( + exception { $stack->pop(Test2::Hub->new) }, + qr/Hub stack mismatch, attempted to pop incorrect hub/, + "Must specify correct hub to pop" +); + +is_deeply( + [ $stack->all ], + [ $hub, $hub ], + "Got all hubs" +); + +ok(!exception { $stack->pop($hub) }, "Popped the correct hub"); + +is_deeply( + [ $stack->all ], + [ $hub ], + "Got all hubs" +); + +is($stack->peek, $hub, "got the hub"); +is($stack->top, $hub, "got the hub"); + +$stack->clear; + +is_deeply( + [ $stack->all ], + [ ], + "no hubs" +); + +ok(my $top = $stack->top, "Generated a top hub"); +is($top->ipc, test2_ipc, "Used sync's ipc"); +ok($top->format, 'Got formatter'); + +is($stack->top, $stack->top, "do not generate a new top if there is already a top"); + +ok(my $new = $stack->new_hub(), "Add a new hub"); +is($stack->top, $new, "new one is on top"); +is($new->ipc, $top->ipc, "inherited ipc"); +is($new->format, $top->format, "inherited formatter"); + +my $new2 = $stack->new_hub(formatter => undef, ipc => undef); +ok(!$new2->ipc, "built with no ipc"); +ok(!$new2->format, "built with no formatter"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event.t b/dist/Test-Simple/t/Test2/modules/Event.t new file mode 100644 index 00000000000..467e7249844 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +use Test2::Event(); + +{ + package My::MockEvent; + + use base 'Test2::Event'; + use Test2::Util::HashBase qw/foo bar baz/; +} + +ok(My::MockEvent->can($_), "Added $_ accessor") for qw/foo bar baz/; + +my $one = My::MockEvent->new(trace => 'fake'); + +ok(!$one->causes_fail, "Events do not cause failures by default"); + +ok(!$one->$_, "$_ is false by default") for qw/increments_count terminate global/; + +ok(!$one->get_meta('xxx'), "no meta-data associated for key 'xxx'"); + +$one->set_meta('xxx', '123'); + +is($one->meta('xxx'), '123', "got meta-data"); + +is($one->meta('xxx', '321'), '123', "did not use default"); + +is($one->meta('yyy', '1221'), '1221', "got the default"); + +is($one->meta('yyy'), '1221', "last call set the value to the default for future use"); + +is($one->summary, 'My::MockEvent', "Default summary is event package"); + +is($one->diagnostics, 0, "Not diagnostics by default"); + +ok(!$one->in_subtest, "no subtest_id by default"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Bail.t b/dist/Test-Simple/t/Test2/modules/Event/Bail.t new file mode 100644 index 00000000000..d323bd9d974 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Bail.t @@ -0,0 +1,29 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; +use Test2::Event::Bail; + +my $bail = Test2::Event::Bail->new( + trace => 'fake', + reason => 'evil', +); + +ok($bail->causes_fail, "bailout always causes fail."); + +is($bail->terminate, 255, "Bail will cause the test to exit."); +is($bail->global, 1, "Bail is global, everything should bail"); + +my $hub = Test2::Hub->new; +ok($hub->is_passing, "passing"); +ok(!$hub->failed, "no failures"); + +$bail->callback($hub); +is($hub->bailed_out, $bail, "set bailed out"); + +is($bail->summary, "Bail out! evil", "Summary includes reason"); +$bail->set_reason(""); +is($bail->summary, "Bail out!", "Summary has no reason"); + +ok($bail->diagnostics, "Bail events are counted as diagnostics"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Diag.t b/dist/Test-Simple/t/Test2/modules/Event/Diag.t new file mode 100644 index 00000000000..9094c0af189 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Diag.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; +use Test2::Event::Diag; +use Test2::Util::Trace; + +my $diag = Test2::Event::Diag->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => 'foo', +); + +is($diag->summary, 'foo', "summary is just message"); + +$diag = Test2::Event::Diag->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => undef, +); + +is($diag->message, 'undef', "set undef message to undef"); +is($diag->summary, 'undef', "summary is just message even when undef"); + +$diag = Test2::Event::Diag->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => {}, +); + +like($diag->message, qr/^HASH\(.*\)$/, "stringified the input value"); + +ok($diag->diagnostics, "Diag events are counted as diagnostics"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Exception.t b/dist/Test-Simple/t/Test2/modules/Event/Exception.t new file mode 100644 index 00000000000..b2bcb6f2db1 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Exception.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; +use Test2::Event::Exception; + +my $exception = Test2::Event::Exception->new( + trace => 'fake', + error => "evil at lake_of_fire.t line 6\n", +); + +ok($exception->causes_fail, "Exception events always cause failure"); + +is($exception->summary, "Exception: evil at lake_of_fire.t line 6", "Got summary"); + +ok($exception->diagnostics, "Exception events are counted as diagnostics"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Generic.t b/dist/Test-Simple/t/Test2/modules/Event/Generic.t new file mode 100644 index 00000000000..5598bee0ba4 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Generic.t @@ -0,0 +1,129 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::Util::Trace; + +use Test2::API qw/context intercept/; + +sub tool { + my $ctx = context(); + my $e = $ctx->send_event('Generic', @_); + $ctx->release; + return $e; +} + +my $e; +intercept { $e = tool() }; + +ok($e, "got event"); +ok($e->isa('Test2::Event'), "It is an event"); +ok($e->isa('Test2::Event::Generic'), "It is an event"); +delete $e->{trace}; +is_deeply( + $e, + { + causes_fail => 0, + increments_count => 0, + diagnostics => 0, + no_display => 0, + }, + "Defaults" +); + +for my $f (qw/causes_fail increments_count diagnostics no_display/) { + is($e->$f, 0, "'$f' is 0"); + is_deeply([$e->$f], [0], "'$f' is 0 is list context as well"); + + my $set = "set_$f"; + $e->$set(1); + is($e->$f, 1, "'$f' was set to 1"); +} + +for my $f (qw/callback terminate global sets_plan/) { + is($e->$f, undef, "no $f"); + is_deeply([$e->$f], [], "$f is empty in list context"); +} + +like($e->summary, qr/Test2::Event::Generic/, "Got base class summary"); + +like( + exception { $e->set_sets_plan('bad') }, + qr/'sets_plan' must be an array reference/, + "Must provide an arrayref" +); + +$e->set_sets_plan([0, skip => 'cause']); +is_deeply([$e->sets_plan], [0, skip => 'cause'], "sets_plan returns a list, not a ref"); +$e->set_sets_plan(undef); +ok(!exists $e->{sets_plan}, "Removed sets_plan key"); +ok(!$e->sets_plan, "sets_plan is cleared"); + +$e->set_global(0); +is($e->global, 0, "global is off"); +$e->set_global(1); +is($e->global, 1, "global is on"); +$e->set_global(0); +is($e->global, 0, "global is again"); +$e->set_global(undef); +ok(!exists $e->{global}, "removed global key"); +is($e->global, undef, "global is not defined"); + +like( + exception { $e->set_callback('dogfood') }, + qr/callback must be a code reference/, + "Callback must be code" +); + +my $ran = 0; +$e->set_callback(sub { + $ran++; + my $self = shift; + is($self, $e, "got self"); + is_deeply( \@_, ['a', 'b', 'c'], "Got args" ); + return 'foo'; +}); +is($e->callback('a', 'b', 'c'), 'foo', "got callback's return"); +ok($ran, "ran callback"); + +$e->set_callback(undef); +ok(!$e->callback, "no callback"); +ok(!exists $e->{callback}, "no callback key"); + +like( + exception { $e->set_terminate('1.1') }, + qr/terminate must be a positive integer/, + "terminate only takes integers" +); + +like( + exception { $e->set_terminate('foo') }, + qr/terminate must be a positive integer/, + "terminate only takes numbers" +); + +like( + exception { $e->set_terminate('-1') }, + qr/terminate must be a positive integer/, + "terminate only takes positive integers" +); + +$e->set_terminate(0), +is($e->terminate, 0, "set to 0, 0 is valid"); +$e->set_terminate(1), +is($e->terminate, 1, "set to 1"); +$e->set_terminate(123), +is($e->terminate, 123, "set to 123"); +$e->set_terminate(0), +is($e->terminate, 0, "set to 0, 0 is valid"); + +$e->set_terminate(undef); +is($e->terminate, undef, "terminate is not defined"); +ok(!exists $e->{terminate}, "no terminate key"); + +# Test constructor args +intercept { $e = tool(causes_fail => 1, increments_count => 'a') }; +is($e->causes_fail, 1, "attr from constructor"); +is($e->increments_count, 'a', "attr from constructor"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Info.t b/dist/Test-Simple/t/Test2/modules/Event/Info.t new file mode 100644 index 00000000000..d908547b01c --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Info.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::Event::Info; +use Test2::Util::Trace; +use Test2::API qw/intercept/; + +my @got; + +my $info = Test2::Event::Info->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + renderer => sub { @got = @_; 'foo' }, +); + +is($info->summary, 'foo', "summary is just rendering"); +is_deeply(\@got, ['text'], "got text"); + +is($info->summary('blah'), 'foo', "summary is just rendering (arg)"); +is_deeply(\@got, ['blah'], "got arg"); + +{ + package An::Info::Thingy; + sub render { shift; @got = @_; 'foo' } +} + +$info = Test2::Event::Info->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + renderer => bless({}, 'An::Info::Thingy'), +); + +is($info->summary, 'foo', "summary is just rendering"); +is_deeply(\@got, ['text'], "got text"); + +is($info->summary('blah'), 'foo', "summary is just rendering (arg)"); +is_deeply(\@got, ['blah'], "got arg"); + +eval { Test2::Event::Info->new(trace => Test2::Util::Trace->new(frame => ['Foo', 'foo.pl', 42])) }; +like( + $@, + qr/'renderer' is a required attribute at foo\.pl line 42/, + "Got expected error" +); + +# For #727 +$info = intercept { ok(0, 'xxx', sub { 'xxx-yyy' }); }->[-1]; +ok($info->isa('Test2::Event::Info'), "Got an Info event"); +is($info->render, 'xxx-yyy', "Got rendered info"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Note.t b/dist/Test-Simple/t/Test2/modules/Event/Note.t new file mode 100644 index 00000000000..0292986aab3 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Note.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::Event::Note; +use Test2::Util::Trace; + +my $note = Test2::Event::Note->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => 'foo', +); + +is($note->summary, 'foo', "summary is just message"); + +$note = Test2::Event::Note->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => undef, +); + +is($note->message, 'undef', "set undef message to undef"); +is($note->summary, 'undef', "summary is just message even when undef"); + +$note = Test2::Event::Note->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => {}, +); + +like($note->message, qr/^HASH\(.*\)$/, "stringified the input value"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Ok.t b/dist/Test-Simple/t/Test2/modules/Event/Ok.t new file mode 100644 index 00000000000..01c255cb1bf --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Ok.t @@ -0,0 +1,90 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::Util::Trace; +use Test2::Event::Ok; +use Test2::Event::Diag; + +use Test2::API qw/context/; + +my $trace; +sub before_each { + # Make sure there is a fresh trace object for each group + $trace = Test2::Util::Trace->new( + frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], + ); +} + +tests Passing => sub { + my $ok = Test2::Event::Ok->new( + trace => $trace, + pass => 1, + name => 'the_test', + ); + ok($ok->increments_count, "Bumps the count"); + ok(!$ok->causes_fail, "Passing 'OK' event does not cause failure"); + is($ok->pass, 1, "got pass"); + is($ok->name, 'the_test', "got name"); + is($ok->effective_pass, 1, "effective pass"); + is($ok->summary, "the_test", "Summary is just the name of the test"); + + $ok = Test2::Event::Ok->new( + trace => $trace, + pass => 1, + name => '', + ); + is($ok->summary, "Nameless Assertion", "Nameless test"); + +}; + +tests Failing => sub { + local $ENV{HARNESS_ACTIVE} = 1; + local $ENV{HARNESS_IS_VERBOSE} = 1; + my $ok = Test2::Event::Ok->new( + trace => $trace, + pass => 0, + name => 'the_test', + ); + ok($ok->increments_count, "Bumps the count"); + ok($ok->causes_fail, "A failing test causes failures"); + is($ok->pass, 0, "got pass"); + is($ok->name, 'the_test', "got name"); + is($ok->effective_pass, 0, "effective pass"); + is($ok->summary, "the_test", "Summary is just the name of the test"); +}; + +tests "Failing TODO" => sub { + local $ENV{HARNESS_ACTIVE} = 1; + local $ENV{HARNESS_IS_VERBOSE} = 1; + my $ok = Test2::Event::Ok->new( + trace => $trace, + pass => 0, + name => 'the_test', + todo => 'A Todo', + ); + ok($ok->increments_count, "Bumps the count"); + is($ok->pass, 0, "got pass"); + is($ok->name, 'the_test', "got name"); + is($ok->effective_pass, 1, "effective pass is true from todo"); + is($ok->summary, "the_test (TODO: A Todo)", "Summary is just the name of the test + todo"); + + $ok = Test2::Event::Ok->new( + trace => $trace, + pass => 0, + name => 'the_test2', + todo => '', + ); + ok($ok->effective_pass, "empty string todo is still a todo"); + is($ok->summary, "the_test2 (TODO)", "Summary is just the name of the test + todo"); +}; + +tests init => sub { + my $ok = Test2::Event::Ok->new( + trace => $trace, + pass => 1, + ); + is($ok->effective_pass, 1, "set effective pass"); +}; + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Plan.t b/dist/Test-Simple/t/Test2/modules/Event/Plan.t new file mode 100644 index 00000000000..25db4a57bf2 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Plan.t @@ -0,0 +1,107 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::Event::Plan; +use Test2::Util::Trace; + +my $plan = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 100, +); + +is($plan->summary, "Plan is 100 assertions", "simple summary"); +is_deeply( [$plan->sets_plan], [100, '', undef], "Got plan details"); + +ok(!$plan->global, "regular plan is not a global event"); +my $state = Test2::Hub->new; +$plan->callback($state); +is($state->plan, 100, "set plan in state"); +is($plan->terminate, undef, "No terminate for normal plan"); + +$plan->set_max(0); +$plan->set_directive('SKIP'); +$plan->set_reason('foo'); +$state = Test2::Hub->new; +$plan->callback($state); +is($state->plan, 'SKIP', "set plan in state"); +is($plan->terminate, 0, "Terminate 0 on skip_all"); + +is($plan->summary, "Plan is 'SKIP', foo", "skip summary"); +is_deeply( [$plan->sets_plan], [0, 'SKIP', 'foo'], "Got skip details"); + +$plan->set_max(0); +$plan->set_directive('NO PLAN'); +$plan->set_reason(undef); +is($plan->summary, "Plan is 'NO PLAN'", "NO PLAN summary"); +is_deeply( [$plan->sets_plan], [0, 'NO PLAN', undef], "Got 'NO PLAN' details"); +$state = Test2::Hub->new; +$plan->callback($state); +is($state->plan, 'NO PLAN', "set plan in state"); +is($plan->terminate, undef, "No terminate for no_plan"); +$plan->set_max(100); +$plan->set_directive(undef); +$plan->callback($state); +is($state->plan, '100', "Update plan in state if it is 'NO PLAN'"); + +$plan = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 0, + directive => 'skip_all', +); +is($plan->directive, 'SKIP', "Change skip_all to SKIP"); + +$plan = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 0, + directive => 'no_plan', +); +is($plan->directive, 'NO PLAN', "Change no_plan to 'NO PLAN'"); +ok(!$plan->global, "NO PLAN is not global"); + +like( + exception { + $plan = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 0, + directive => 'foo', + ); + }, + qr/'foo' is not a valid plan directive/, + "Invalid Directive" +); + +like( + exception { + $plan = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 0, + reason => 'foo', + ); + }, + qr/Cannot have a reason without a directive!/, + "Reason without directive" +); + +like( + exception { + $plan = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + ); + }, + qr/No number of tests specified/, + "Nothing to do" +); + +like( + exception { + $plan = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 'skip', + ); + }, + qr/Plan test count 'skip' does not appear to be a valid positive integer/, + "Max must be an integer" +); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Skip.t b/dist/Test-Simple/t/Test2/modules/Event/Skip.t new file mode 100644 index 00000000000..89018794ee1 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Skip.t @@ -0,0 +1,24 @@ +use Test2::Tools::Tiny; +use strict; +use warnings; + +use Test2::Event::Skip; +use Test2::Util::Trace; + +my $skip = Test2::Event::Skip->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + name => 'skip me', + reason => 'foo', +); + +is($skip->name, 'skip me', "set name"); +is($skip->reason, 'foo', "got skip reason"); +ok(!$skip->pass, "no default for pass"); +ok($skip->effective_pass, "TODO always effectively passes"); + +is($skip->summary, "skip me (SKIP: foo)", "summary with reason"); + +$skip->set_reason(''); +is($skip->summary, "skip me (SKIP)", "summary without reason"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Subtest.t b/dist/Test-Simple/t/Test2/modules/Event/Subtest.t new file mode 100644 index 00000000000..56e1184079f --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Subtest.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::Event::Subtest; +my $st = 'Test2::Event::Subtest'; + +my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']); +my $one = $st->new( + trace => $trace, + pass => 1, + buffered => 1, + name => 'foo', + subtest_id => "1-1-1", +); + +ok($one->isa('Test2::Event::Ok'), "Inherit from Ok"); +is_deeply($one->subevents, [], "subevents is an arrayref"); + +is($one->summary, "foo", "simple summary"); +$one->set_todo(''); +is($one->summary, "foo (TODO)", "simple summary + TODO"); +$one->set_todo('foo'); +is($one->summary, "foo (TODO: foo)", "simple summary + TODO + Reason"); + +$one->set_todo(undef); +$one->set_name(''); +is($one->summary, "Nameless Subtest", "unnamed summary"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Event/Waiting.t b/dist/Test-Simple/t/Test2/modules/Event/Waiting.t new file mode 100644 index 00000000000..26b7fbb41f3 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Event/Waiting.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::Event::Waiting; + +my $waiting = Test2::Event::Waiting->new( + trace => 'fake', +); + +ok($waiting, "Created event"); +ok($waiting->global, "waiting is global"); + +is($waiting->summary, "IPC is waiting for children to finish...", "Got summary"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Formatter/TAP.t b/dist/Test-Simple/t/Test2/modules/Formatter/TAP.t new file mode 100644 index 00000000000..2cf92b8270d --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Formatter/TAP.t @@ -0,0 +1,550 @@ +use strict; +use warnings; +use Test2::Formatter::TAP; +use Test2::API qw/context/; +use PerlIO; + +use Test2::Tools::Tiny; + +BEGIN { + *OUT_STD = Test2::Formatter::TAP->can('OUT_STD') or die; + *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR') or die; +} + +use Test2::API; +Test2::API::test2_add_callback_context_release(sub { + my $ctx = shift; + return if $ctx->hub->is_passing; + $ctx->throw("(Die On Fail)"); +}); + +ok(my $one = Test2::Formatter::TAP->new, "Created a new instance"); +my $handles = $one->handles; +is(@$handles, 2, "Got 2 handles"); +ok($handles->[0] != $handles->[1], "First and second handles are not the same"); +my $layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; + +if (${^UNICODE} & 2) { # 2 means STDIN + ok($layers->{utf8}, "'S' is set in PERL_UNICODE, or in -C, honor it, utf8 should be on") +} +else { + ok(!$layers->{utf8}, "Not utf8 by default") +} + +$one->encoding('utf8'); +is($one->encoding, 'utf8', "Got encoding"); +$handles = $one->handles; +is(@$handles, 2, "Got 2 handles"); +$layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; +ok($layers->{utf8}, "Now utf8"); + +my $two = Test2::Formatter::TAP->new(encoding => 'utf8'); +$handles = $two->handles; +is(@$handles, 2, "Got 2 handles"); +$layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; +ok($layers->{utf8}, "Now utf8"); + + +{ + package My::Event; + + use base 'Test2::Event'; + use Test2::Util::HashBase qw{pass name diag note}; + + Test2::Formatter::TAP->register_event( + __PACKAGE__, + sub { + my $self = shift; + my ($e, $num) = @_; + return ( + [main::OUT_STD, "ok $num - " . $e->name . "\n"], + [main::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"], + [main::OUT_STD, "# " . $e->name . " " . $e->note . "\n"], + ); + } + ); +} + +my ($std, $err); +open( my $stdh, '>', \$std ) || die "Ooops"; +open( my $errh, '>', \$err ) || die "Ooops"; + +my $it = Test2::Formatter::TAP->new( + handles => [$stdh, $errh, $stdh], +); + +$it->write( + My::Event->new( + pass => 1, + name => 'foo', + diag => 'diag', + note => 'note', + trace => 'fake', + ), + 55, +); + +$it->write( + My::Event->new( + pass => 1, + name => 'bar', + diag => 'diag', + note => 'note', + trace => 'fake', + nested => 1, + ), + 1, +); + +is($std, <new; +sub before_each { + # Make sure there is a fresh trace object for each group + $trace = Test2::Util::Trace->new( + frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], + ); +} + +tests bail => sub { + my $bail = Test2::Event::Bail->new( + trace => $trace, + reason => 'evil', + ); + + is_deeply( + [$fmt->event_tap($bail, 1)], + [[OUT_STD, "Bail out! evil\n" ]], + "Got tap" + ); +}; + +tests diag => sub { + my $diag = Test2::Event::Diag->new( + trace => $trace, + message => 'foo', + ); + + is_deeply( + [$fmt->event_tap($diag, 1)], + [[OUT_ERR, "# foo\n"]], + "Got tap" + ); + + $diag->set_message("foo\n"); + is_deeply( + [$fmt->event_tap($diag, 1)], + [[OUT_ERR, "# foo\n"]], + "Only 1 newline" + ); + + $diag->set_message("foo\nbar\nbaz"); + is_deeply( + [$fmt->event_tap($diag, 1)], + [[OUT_ERR, "# foo\n# bar\n# baz\n"]], + "All lines have proper prefix" + ); +}; + +tests exception => sub { + my $exception = Test2::Event::Exception->new( + trace => $trace, + error => "evil at lake_of_fire.t line 6\n", + ); + + is_deeply( + [$fmt->event_tap($exception, 1)], + [[OUT_ERR, "evil at lake_of_fire.t line 6\n" ]], + "Got tap" + ); +}; + +tests note => sub { + my $note = Test2::Event::Note->new( + trace => $trace, + message => 'foo', + ); + + is_deeply( + [$fmt->event_tap($note, 1)], + [[OUT_STD, "# foo\n"]], + "Got tap" + ); + + $note->set_message("foo\n"); + is_deeply( + [$fmt->event_tap($note, 1)], + [[OUT_STD, "# foo\n"]], + "Only 1 newline" + ); + + $note->set_message("foo\nbar\nbaz"); + is_deeply( + [$fmt->event_tap($note, 1)], + [[OUT_STD, "# foo\n# bar\n# baz\n"]], + "All lines have proper prefix" + ); +}; + +tests special_characters => sub { + my $ok = Test2::Event::Ok->new( + trace => $trace, + name => 'nothing special', + pass => 1, + ); + + is_deeply( + [$fmt->event_tap($ok, 1)], + [[OUT_STD, "ok 1 - nothing special\n"]], + "Got regular ok" + ); + + $ok = Test2::Event::Ok->new( + trace => $trace, + name => 'just a \\ slash', + pass => 1, + ); + + is_deeply( + [$fmt->event_tap($ok, 1)], + [[OUT_STD, "ok 1 - just a \\ slash\n"]], + "Do not escape slashes without a '#'" + ); + + $ok = Test2::Event::Ok->new( + trace => $trace, + name => 'a \\ slash and a # hash', + pass => 1, + ); + + is_deeply( + [$fmt->event_tap($ok, 1)], + [[OUT_STD, "ok 1 - a \\\\ slash and a \\# hash\n"]], + "Escape # and any slashes already present" + ); + + $ok = Test2::Event::Ok->new( + trace => $trace, + name => "a \\ slash and a # hash\nand \\ some # newlines\nlike this # \\", + pass => 1, + ); + + is_deeply( + [$fmt->event_tap($ok, 1)], + [ + [OUT_STD, "ok 1 - a \\\\ slash and a \\# hash\n"], + [OUT_STD, "# and \\ some # newlines\n"], + [OUT_STD, "# like this # \\\n"], + ], + "Escape # and any slashes already present, and split newlines, do not escape the newlines" + ); + + $ok = Test2::Event::Ok->new( + trace => $trace, + name => "Nothing special until the end \\\nfoo \\ bar", + pass => 1, + ); + + is_deeply( + [$fmt->event_tap($ok, 1)], + [ + [OUT_STD, "ok 1 - Nothing special until the end \\\\\n"], + [OUT_STD, "# foo \\ bar\n"], + ], + "Special case, escape things if last character of the first line is a \\" + ); + +}; + +for my $pass (1, 0) { + local $ENV{HARNESS_IS_VERBOSE} = 1; + tests name_and_number => sub { + my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo'); + my @tap = $fmt->event_tap($ok, 7); + is_deeply( + \@tap, + [ + [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 - foo\n"], + ], + "Got expected output" + ); + }; + + tests no_number => sub { + my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo'); + my @tap = $fmt->event_tap($ok, ); + is_deeply( + \@tap, + [ + [OUT_STD, ($pass ? 'ok' : 'not ok') . " - foo\n"], + ], + "Got expected output" + ); + }; + + tests no_name => sub { + my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass); + my @tap = $fmt->event_tap($ok, 7); + is_deeply( + \@tap, + [ + [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7\n"], + ], + "Got expected output" + ); + }; + + tests todo => sub { + my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass); + $ok->set_todo('b'); + my @tap = $fmt->event_tap($ok, 7); + is_deeply( + \@tap, + [ + [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO b\n"], + ], + "Got expected output" + ); + + $ok->set_todo(""); + + @tap = $fmt->event_tap($ok, 7); + is_deeply( + \@tap, + [ + [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO\n"], + ], + "Got expected output" + ); + }; +}; + +tests plan => sub { + my $plan = Test2::Event::Plan->new( + trace => $trace, + max => 100, + ); + + is_deeply( + [$fmt->event_tap($plan, 1)], + [[OUT_STD, "1..100\n"]], + "Got tap" + ); + + $plan->set_max(0); + $plan->set_directive('SKIP'); + $plan->set_reason('foo'); + is_deeply( + [$fmt->event_tap($plan, 1)], + [[OUT_STD, "1..0 # SKIP foo\n"]], + "Got tap for skip_all" + ); + + $plan = Test2::Event::Plan->new( + trace => $trace, + max => 0, + directive => 'skip_all', + ); + is_deeply( + [$fmt->event_tap($plan)], + [[OUT_STD, "1..0 # SKIP\n"]], + "SKIP without reason" + ); + + $plan = Test2::Event::Plan->new( + trace => $trace, + max => 0, + directive => 'no_plan', + ); + is_deeply( + [$fmt->event_tap($plan)], + [], + "NO PLAN" + ); + + $plan = Test2::Event::Plan->new( + trace => $trace, + max => 0, + directive => 'skip_all', + reason => "Foo\nBar\nBaz", + ); + is_deeply( + [$fmt->event_tap($plan)], + [ + [OUT_STD, "1..0 # SKIP Foo\n# Bar\n# Baz\n"], + ], + "Multi-line reason for skip" + ); +}; + +tests subtest => sub { + my $st = 'Test2::Event::Subtest'; + + my $one = $st->new( + trace => $trace, + pass => 1, + buffered => 1, + name => 'foo', + subtest_id => '1-1-1', + ); + + is_deeply( + [$fmt->event_tap($one, 5)], + [ + [OUT_STD, "ok 5 - foo {\n"], + [OUT_STD, "}\n"], + ], + "Got Buffered TAP output" + ); + + $one->set_buffered(0); + is_deeply( + [$fmt->event_tap($one, 5)], + [ + [OUT_STD, "ok 5 - foo\n"], + ], + "Got Unbuffered TAP output" + ); + + $one = $st->new( + trace => $trace, + pass => 0, + buffered => 1, + name => 'bar', + subtest_id => '1-1-1', + subevents => [ + Test2::Event::Ok->new(trace => $trace, name => 'first', pass => 1), + Test2::Event::Ok->new(trace => $trace, name => 'second', pass => 0), + Test2::Event::Ok->new(trace => $trace, name => 'third', pass => 1), + + Test2::Event::Diag->new(trace => $trace, message => 'blah blah'), + + Test2::Event::Plan->new(trace => $trace, max => 3), + ], + ); + + { + local $ENV{HARNESS_IS_VERBOSE}; + is_deeply( + [$fmt->event_tap($one, 5)], + [ + [OUT_STD, "not ok 5 - bar {\n"], + [OUT_STD, " ok 1 - first\n"], + [OUT_STD, " not ok 2 - second\n"], + [OUT_STD, " ok 3 - third\n"], + [OUT_ERR, " # blah blah\n"], + [OUT_STD, " 1..3\n"], + [OUT_STD, "}\n"], + ], + "Got Buffered TAP output (non-verbose)" + ); + } + + { + local $ENV{HARNESS_IS_VERBOSE} = 1; + is_deeply( + [$fmt->event_tap($one, 5)], + [ + [OUT_STD, "not ok 5 - bar {\n"], + [OUT_STD, " ok 1 - first\n"], + [OUT_STD, " not ok 2 - second\n"], + [OUT_STD, " ok 3 - third\n"], + [OUT_ERR, " # blah blah\n"], + [OUT_STD, " 1..3\n"], + [OUT_STD, "}\n"], + ], + "Got Buffered TAP output (verbose)" + ); + } + + { + local $ENV{HARNESS_IS_VERBOSE}; + $one->set_buffered(0); + is_deeply( + [$fmt->event_tap($one, 5)], + [ + # In unbuffered TAP the subevents are rendered outside of this. + [OUT_STD, "not ok 5 - bar\n"], + ], + "Got Unbuffered TAP output (non-verbose)" + ); + } + + { + local $ENV{HARNESS_IS_VERBOSE} = 1; + $one->set_buffered(0); + is_deeply( + [$fmt->event_tap($one, 5)], + [ + # In unbuffered TAP the subevents are rendered outside of this. + [OUT_STD, "not ok 5 - bar\n"], + ], + "Got Unbuffered TAP output (verbose)" + ); + } +}; + +tests skip => sub { + my $skip = Test2::Event::Skip->new(trace => $trace, pass => 1, name => 'foo', reason => 'xxx'); + my @tap = $fmt->event_tap($skip, 7); + is_deeply( + \@tap, + [ + [OUT_STD, "ok 7 - foo # skip xxx\n"], + ], + "Passing Skip" + ); + + $skip->set_pass(0); + @tap = $fmt->event_tap($skip, 7); + is_deeply( + \@tap, + [ + [OUT_STD, "not ok 7 - foo # skip xxx\n"], + ], + "Failling Skip" + ); + + $skip->set_todo("xxx"); + @tap = $fmt->event_tap($skip, 7); + is_deeply( + \@tap, + [ + [OUT_STD, "not ok 7 - foo # TODO & SKIP xxx\n"], + ], + "Todo Skip" + ); +}; + +tests version => sub { + require Test2::Event::TAP::Version; + my $ver = Test2::Event::TAP::Version->new( + trace => $trace, + version => '2', + ); + + is_deeply( + [$fmt->event_tap($ver, 1)], + [[OUT_STD, "TAP version 2\n"]], + "Got tap" + ); +}; + + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Hub.t b/dist/Test-Simple/t/Test2/modules/Hub.t new file mode 100644 index 00000000000..1d31a6097f8 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Hub.t @@ -0,0 +1,484 @@ +use strict; +use warnings; + +use Test2::IPC; +use Test2::Tools::Tiny; +use Test2::API qw/context test2_ipc_drivers/; +use Test2::Util qw/CAN_FORK CAN_THREAD CAN_REALLY_FORK/; + +{ + package My::Formatter; + + sub new { bless [], shift }; + + my $check = 1; + sub write { + my $self = shift; + my ($e, $count) = @_; + push @$self => $e; + } +} + +{ + package My::Event; + + use base 'Test2::Event'; + use Test2::Util::HashBase qw{msg}; +} + +tests basic => sub { + my $hub = Test2::Hub->new( + formatter => My::Formatter->new, + ); + + my $send_event = sub { + my ($msg) = @_; + my $e = My::Event->new(msg => $msg, trace => 'fake'); + $hub->send($e); + }; + + ok(my $e1 = $send_event->('foo'), "Created event"); + ok(my $e2 = $send_event->('bar'), "Created event"); + ok(my $e3 = $send_event->('baz'), "Created event"); + + my $old = $hub->format(My::Formatter->new); + + ok($old->isa('My::Formatter'), "old formatter"); + is_deeply( + $old, + [$e1, $e2, $e3], + "Formatter got all events" + ); +}; + +tests follow_ups => sub { + my $hub = Test2::Hub->new; + $hub->set_count(1); + + my $trace = Test2::Util::Trace->new( + frame => [__PACKAGE__, __FILE__, __LINE__], + ); + + my $ran = 0; + $hub->follow_up(sub { + my ($d, $h) = @_; + is_deeply($d, $trace, "Got trace"); + is_deeply($h, $hub, "Got hub"); + ok(!$hub->ended, "Hub state has not ended yet"); + $ran++; + }); + + like( + exception { $hub->follow_up('xxx') }, + qr/follow_up only takes coderefs for arguments, got 'xxx'/, + "follow_up takes a coderef" + ); + + $hub->finalize($trace); + + is($ran, 1, "ran once"); + + is_deeply( + $hub->ended, + $trace->frame, + "Ended at the expected place." + ); + + eval { $hub->finalize($trace) }; + + is($ran, 1, "ran once"); + + $hub = undef; +}; + +tests IPC => sub { + my ($driver) = test2_ipc_drivers(); + is($driver, 'Test2::IPC::Driver::Files', "Default Driver"); + my $ipc = $driver->new; + my $hub = Test2::Hub->new( + formatter => My::Formatter->new, + ipc => $ipc, + ); + + my $build_event = sub { + my ($msg) = @_; + return My::Event->new(msg => $msg, trace => 'fake'); + }; + + my $e1 = $build_event->('foo'); + my $e2 = $build_event->('bar'); + my $e3 = $build_event->('baz'); + + my $do_send = sub { + $hub->send($e1); + $hub->send($e2); + $hub->send($e3); + }; + + my $do_check = sub { + my $name = shift; + + my $old = $hub->format(My::Formatter->new); + + ok($old->isa('My::Formatter'), "old formatter"); + is_deeply( + $old, + [$e1, $e2, $e3], + "Formatter got all events ($name)" + ); + }; + + if (CAN_REALLY_FORK) { + my $pid = fork(); + die "Could not fork!" unless defined $pid; + + if ($pid) { + is(waitpid($pid, 0), $pid, "waited properly"); + ok(!$?, "child exited with success"); + $hub->cull(); + $do_check->('Fork'); + } + else { + $do_send->(); + exit 0; + } + } + + if (CAN_THREAD && $] ge '5.010') { + require threads; + my $thr = threads->new(sub { $do_send->() }); + $thr->join; + $hub->cull(); + $do_check->('Threads'); + } + + $do_send->(); + $hub->cull(); + $do_check->('no IPC'); +}; + +tests listen => sub { + my $hub = Test2::Hub->new(); + + my @events; + my @counts; + my $it = $hub->listen(sub { + my ($h, $e, $count) = @_; + is_deeply($h, $hub, "got hub"); + push @events => $e; + push @counts => $count; + }); + + my $second; + my $it2 = $hub->listen(sub { $second++ }); + + my $ok1 = Test2::Event::Ok->new( + pass => 1, + name => 'foo', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + my $ok2 = Test2::Event::Ok->new( + pass => 0, + name => 'bar', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + my $ok3 = Test2::Event::Ok->new( + pass => 1, + name => 'baz', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + $hub->send($ok1); + $hub->send($ok2); + + $hub->unlisten($it); + + $hub->send($ok3); + + is_deeply(\@counts, [1, 2], "Got counts"); + is_deeply(\@events, [$ok1, $ok2], "got events"); + is($second, 3, "got all events in listener that was not removed"); + + like( + exception { $hub->listen('xxx') }, + qr/listen only takes coderefs for arguments, got 'xxx'/, + "listen takes a coderef" + ); +}; + +tests metadata => sub { + my $hub = Test2::Hub->new(); + + my $default = { foo => 1 }; + my $meta = $hub->meta('Foo', $default); + is_deeply($meta, $default, "Set Meta"); + + $meta = $hub->meta('Foo', {}); + is_deeply($meta, $default, "Same Meta"); + + $hub->delete_meta('Foo'); + is($hub->meta('Foo'), undef, "No Meta"); + + $hub->meta('Foo', {})->{xxx} = 1; + is($hub->meta('Foo')->{xxx}, 1, "Vivified meta and set it"); + + like( + exception { $hub->meta(undef) }, + qr/Invalid META key: undef, keys must be true, and may not be references/, + "Cannot use undef as a meta key" + ); + + like( + exception { $hub->meta(0) }, + qr/Invalid META key: '0', keys must be true, and may not be references/, + "Cannot use 0 as a meta key" + ); + + like( + exception { $hub->delete_meta(undef) }, + qr/Invalid META key: undef, keys must be true, and may not be references/, + "Cannot use undef as a meta key" + ); + + like( + exception { $hub->delete_meta(0) }, + qr/Invalid META key: '0', keys must be true, and may not be references/, + "Cannot use 0 as a meta key" + ); +}; + +tests filter => sub { + my $hub = Test2::Hub->new(); + + my @events; + my $it = $hub->filter(sub { + my ($h, $e) = @_; + is($h, $hub, "got hub"); + push @events => $e; + return $e; + }); + + my $count; + my $it2 = $hub->filter(sub { $count++; $_[1] }); + + my $ok1 = Test2::Event::Ok->new( + pass => 1, + name => 'foo', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + my $ok2 = Test2::Event::Ok->new( + pass => 0, + name => 'bar', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + my $ok3 = Test2::Event::Ok->new( + pass => 1, + name => 'baz', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + $hub->send($ok1); + $hub->send($ok2); + + $hub->unfilter($it); + + $hub->send($ok3); + + is_deeply(\@events, [$ok1, $ok2], "got events"); + is($count, 3, "got all events, even after other filter was removed"); + + $hub = Test2::Hub->new(); + @events = (); + + $hub->filter(sub { undef }); + $hub->listen(sub { + my ($hub, $e) = @_; + push @events => $e; + }); + + $hub->send($ok1); + $hub->send($ok2); + $hub->send($ok3); + + ok(!@events, "Blocked events"); + + like( + exception { $hub->filter('xxx') }, + qr/filter only takes coderefs for arguments, got 'xxx'/, + "filter takes a coderef" + ); +}; + +tests pre_filter => sub { + my $hub = Test2::Hub->new(); + + my @events; + my $it = $hub->pre_filter(sub { + my ($h, $e) = @_; + is($h, $hub, "got hub"); + push @events => $e; + return $e; + }); + + my $count; + my $it2 = $hub->pre_filter(sub { $count++; $_[1] }); + + my $ok1 = Test2::Event::Ok->new( + pass => 1, + name => 'foo', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + my $ok2 = Test2::Event::Ok->new( + pass => 0, + name => 'bar', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + my $ok3 = Test2::Event::Ok->new( + pass => 1, + name => 'baz', + trace => Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__ ], + ), + ); + + $hub->send($ok1); + $hub->send($ok2); + + $hub->pre_unfilter($it); + + $hub->send($ok3); + + is_deeply(\@events, [$ok1, $ok2], "got events"); + is($count, 3, "got all events, even after other pre_filter was removed"); + + $hub = Test2::Hub->new(); + @events = (); + + $hub->pre_filter(sub { undef }); + $hub->listen(sub { + my ($hub, $e) = @_; + push @events => $e; + }); + + $hub->send($ok1); + $hub->send($ok2); + $hub->send($ok3); + + ok(!@events, "Blocked events"); + + like( + exception { $hub->pre_filter('xxx') }, + qr/pre_filter only takes coderefs for arguments, got 'xxx'/, + "pre_filter takes a coderef" + ); +}; + +tests state => sub { + my $hub = Test2::Hub->new; + + is($hub->count, 0, "count starts at 0"); + is($hub->failed, 0, "failed starts at 0"); + is($hub->is_passing, 1, "start off passing"); + is($hub->plan, undef, "no plan yet"); + + $hub->is_passing(0); + is($hub->is_passing, 0, "Can Fail"); + + $hub->is_passing(1); + is($hub->is_passing, 1, "Passes again"); + + $hub->set_count(1); + is($hub->count, 1, "Added a passing result"); + is($hub->failed, 0, "still no fails"); + is($hub->is_passing, 1, "Still passing"); + + $hub->set_count(2); + $hub->set_failed(1); + is($hub->count, 2, "Added a result"); + is($hub->failed, 1, "new failure"); + is($hub->is_passing, 0, "Not passing"); + + $hub->is_passing(1); + is($hub->is_passing, 0, "is_passing always false after a failure"); + + $hub->set_failed(0); + $hub->is_passing(1); + is($hub->is_passing, 1, "Passes again"); + + $hub->set_failed(1); + is($hub->count, 2, "No new result"); + is($hub->failed, 1, "new failure"); + is($hub->is_passing, 0, "Not passing"); + + ok(!eval { $hub->plan('foo'); 1 }, "Could not set plan to 'foo'"); + like($@, qr/'foo' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'/, "Got expected error"); + + ok($hub->plan(5), "Can set plan to integer"); + is($hub->plan, 5, "Set the plan to an integer"); + + $hub->set__plan(undef); + ok($hub->plan('NO PLAN'), "Can set plan to 'NO PLAN'"); + is($hub->plan, 'NO PLAN', "Set the plan to 'NO PLAN'"); + + $hub->set__plan(undef); + ok($hub->plan('SKIP'), "Can set plan to 'SKIP'"); + is($hub->plan, 'SKIP', "Set the plan to 'SKIP'"); + + ok(!eval { $hub->plan(5); 1 }, "Cannot change plan"); + like($@, qr/You cannot change the plan/, "Got error"); + + my $trace = Test2::Util::Trace->new(frame => ['Foo::Bar', 'foo.t', 42, 'blah']); + $hub->finalize($trace); + my $ok = eval { $hub->finalize($trace) }; + my $err = $@; + ok(!$ok, "died"); + + is($err, <<" EOT", "Got expected error"); +Test already ended! +First End: foo.t line 42 +Second End: foo.t line 42 + EOT + + $hub = Test2::Hub->new; + + $hub->plan(5); + $hub->set_count(5); + $hub->set_failed(1); + $hub->set_ended($trace); + $hub->set_bailed_out("foo"); + $hub->set_skip_reason('xxx'); + ok(!$hub->is_passing, "not passing"); + + $hub->reset_state; + + ok(!$hub->plan, "no plan"); + is($hub->count, 0, "count reset to 0"); + is($hub->failed, 0, "reset failures"); + ok(!$hub->ended, "not ended"); + ok(!$hub->bailed_out, "did not bail out"); + ok(!$hub->skip_reason, "no skip reason"); +}; + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Hub/Interceptor.t b/dist/Test-Simple/t/Test2/modules/Hub/Interceptor.t new file mode 100644 index 00000000000..71cd56a6ce7 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Hub/Interceptor.t @@ -0,0 +1,15 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +use Test2::Hub::Interceptor; + +my $one = Test2::Hub::Interceptor->new(); + +ok($one->isa('Test2::Hub'), "inheritence");; + +my $e = exception { $one->terminate(55) }; +ok($e->isa('Test2::Hub::Interceptor::Terminator'), "exception type"); +like($$e, 'Label not found for "last T2_SUBTEST_WRAPPER"', "Could not find label"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Hub/Interceptor/Terminator.t b/dist/Test-Simple/t/Test2/modules/Hub/Interceptor/Terminator.t new file mode 100644 index 00000000000..2889aacf4d0 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Hub/Interceptor/Terminator.t @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +use Test2::Hub::Interceptor::Terminator; + +ok($INC{'Test2/Hub/Interceptor/Terminator.pm'}, "loaded"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Hub/Subtest.t b/dist/Test-Simple/t/Test2/modules/Hub/Subtest.t new file mode 100644 index 00000000000..b0bf9f029fc --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Hub/Subtest.t @@ -0,0 +1,124 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +use Test2::Hub::Subtest; +use Test2::Util qw/get_tid/; +use Carp qw/croak/; + +my %TODO; + +sub def { + my ($func, @args) = @_; + + my @caller = caller(0); + + $TODO{$caller[0]} ||= []; + push @{$TODO{$caller[0]}} => [$func, \@args, \@caller]; +} + +sub do_def { + my $for = caller; + my $tests = delete $TODO{$for} or croak "No tests to run!"; + + for my $test (@$tests) { + my ($func, $args, $caller) = @$test; + + my ($pkg, $file, $line) = @$caller; + +# Note: The '&' below is to bypass the prototype, which is important here. + eval <<" EOT" or die $@; +package $pkg; +# line $line "(eval in DeferredTests) $file" +\&$func(\@\$args); +1; + EOT + } +} + +my $ran = 0; +my $event; + +my $one = Test2::Hub::Subtest->new( + nested => 3, +); + +ok($one->isa('Test2::Hub'), "inheritence"); + +{ + no warnings 'redefine'; + local *Test2::Hub::process = sub { $ran++; (undef, $event) = @_; 'P!' }; + use warnings; + + my $ok = Test2::Event::Ok->new( + pass => 1, + name => 'blah', + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), + ); + + def is => ($one->process($ok), 'P!', "processed"); + def is => ($ran, 1, "ran the mocked process"); + def is => ($event, $ok, "got our event"); + def is => ($event->nested, 3, "nested was set"); + def is => ($one->bailed_out, undef, "did not bail"); + + $ran = 0; + $event = undef; + + my $bail = Test2::Event::Bail->new( + message => 'blah', + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), + ); + + def is => ($one->process($bail), 'P!', "processed"); + def is => ($ran, 1, "ran the mocked process"); + def is => ($event, $bail, "got our event"); + def is => ($event->nested, 3, "nested was set"); + def is => ($one->bailed_out, $event, "bailed"); +} + +do_def; + +my $skip = Test2::Event::Plan->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__], pid => $$, tid => get_tid), + directive => 'SKIP', + reason => 'foo', +); + +$ran = 0; +T2_SUBTEST_WRAPPER: { + $ran++; + $one->terminate(100, $skip); + $ran++; +} +is($ran, 1, "did not get past the terminate"); + +$ran = 0; +T2_SUBTEST_WRAPPER: { + $ran++; + $one->send($skip); + $ran++; +} +is($ran, 1, "did not get past the terminate"); + +$one->reset_state; +$one->set_manual_skip_all(1); + +$ran = 0; +T2_SUBTEST_WRAPPER: { + $ran++; + $one->terminate(100, $skip); + $ran++; +} +is($ran, 2, "did not automatically abort"); + +$one->reset_state; +$ran = 0; +T2_SUBTEST_WRAPPER: { + $ran++; + $one->send($skip); + $ran++; +} +is($ran, 2, "did not automatically abort"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/IPC.t b/dist/Test-Simple/t/Test2/modules/IPC.t new file mode 100644 index 00000000000..ddd49c0d9e8 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/IPC.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test2::IPC qw/cull/; +use Test2::API qw/context test2_ipc_drivers test2_ipc/; + +use Test2::Tools::Tiny; + +test2_ipc(); + +is_deeply( + [test2_ipc_drivers()], + ['Test2::IPC::Driver::Files'], + "Default driver" +); + +ok(__PACKAGE__->can('cull'), "Imported cull"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/IPC/Driver.t b/dist/Test-Simple/t/Test2/modules/IPC/Driver.t new file mode 100644 index 00000000000..cbdca09b776 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/IPC/Driver.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test2::IPC::Driver::Files; + +use Test2::Tools::Tiny; +use Test2::API qw/context test2_ipc_drivers/; + +Test2::IPC::Driver::Files->import(); +Test2::IPC::Driver::Files->import(); +Test2::IPC::Driver::Files->import(); + +is_deeply( + [test2_ipc_drivers()], + ['Test2::IPC::Driver::Files'], + "Driver not added multiple times" +); + +for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { + my $one = Test2::IPC::Driver->new; + like( + exception { $one->$meth }, + qr/'\Q$one\E' did not define the required method '$meth'/, + "Require override of method $meth" + ); +} + +tests abort => sub { + my $one = Test2::IPC::Driver->new(no_fatal => 1); + my ($err, $out) = ("", ""); + + { + local *STDERR; + local *STDOUT; + open(STDERR, '>', \$err); + open(STDOUT, '>', \$out); + $one->abort('foo'); + } + + is($err, "IPC Fatal Error: foo\n", "Got error"); + is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout"); + + ($err, $out) = ("", ""); + + { + local *STDERR; + local *STDOUT; + open(STDERR, '>', \$err); + open(STDOUT, '>', \$out); + $one->abort_trace('foo'); + } + + is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout"); + like($err, qr/IPC Fatal Error: foo/, "Got error"); +}; + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/IPC/Driver/Files.t b/dist/Test-Simple/t/Test2/modules/IPC/Driver/Files.t new file mode 100644 index 00000000000..0e79101d51f --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/IPC/Driver/Files.t @@ -0,0 +1,527 @@ +use Test2::Tools::Tiny; +use Test2::Util qw/get_tid USE_THREADS try ipc_separator/; +use File::Temp qw/tempfile/; +use File::Spec qw/catfile/; +use List::Util qw/shuffle/; +use strict; +use warnings; + +sub simple_capture(&) { + my $code = shift; + + my ($err, $out) = ("", ""); + + my ($ok, $e); + { + local *STDOUT; + local *STDERR; + + ($ok, $e) = try { + open(STDOUT, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; + open(STDERR, '>', \$err) or die "Failed to open a temporary STDERR: $!"; + + $code->(); + }; + } + + die $e unless $ok; + + return { + STDOUT => $out, + STDERR => $err, + }; +} + +require Test2::IPC::Driver::Files; +ok(my $ipc = Test2::IPC::Driver::Files->new, "Created an IPC instance"); +ok($ipc->isa('Test2::IPC::Driver::Files'), "Correct type"); +ok($ipc->isa('Test2::IPC::Driver'), "inheritence"); + +ok(-d $ipc->tempdir, "created temp dir"); +is($ipc->pid, $$, "stored pid"); +is($ipc->tid, get_tid(), "stored the tid"); + +my $hid = join ipc_separator, qw'12345 1 1'; + +$ipc->add_hub($hid); +my $hubfile = File::Spec->catfile($ipc->tempdir, "HUB" . ipc_separator . $hid); +ok(-f $hubfile, "wrote hub file"); +if(ok(open(my $fh, '<', $hubfile), "opened hub file")) { + my @lines = <$fh>; + close($fh); + is_deeply( + \@lines, + [ "$$\n", get_tid() . "\n" ], + "Wrote pid and tid to hub file" + ); +} + +{ + package Foo; + use base 'Test2::Event'; +} + +$ipc->send($hid, bless({ foo => 1 }, 'Foo')); +$ipc->send($hid, bless({ bar => 1 }, 'Foo')); + +my $sep = ipc_separator; +opendir(my $dh, $ipc->tempdir) || die "Could not open tempdir: !?"; +my @files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB${sep}$hid/ } readdir($dh); +closedir($dh); +is(@files, 2, "2 files added to the IPC directory"); + +my @events = $ipc->cull($hid); +is_deeply( + \@events, + [{ foo => 1 }, { bar => 1 }], + "Culled both events" +); + +opendir($dh, $ipc->tempdir) || die "Could not open tempdir: !?"; +@files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB$sep$hid/ } readdir($dh); +closedir($dh); +is(@files, 0, "All files collected"); + +$ipc->drop_hub($hid); +ok(!-f $ipc->tempdir . '/' . $hid, "removed hub file"); + +$ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL'); +my @got = $ipc->cull($hid); +ok(@got == 0, "did not get our own global event"); + +my $tmpdir = $ipc->tempdir; +ok(-d $tmpdir, "still have temp dir"); +$ipc = undef; +ok(!-d $tmpdir, "cleaned up temp dir"); + +{ + my $ipc = Test2::IPC::Driver::Files->new(); + + my $tmpdir = $ipc->tempdir; + + my $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; + $ipc_thread_clone->set_tid(100); + $ipc_thread_clone = undef; + ok(-d $tmpdir, "Directory not removed (different thread)"); + + my $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; + $ipc_fork_clone->set_pid($$ + 10); + $ipc_fork_clone = undef; + ok(-d $tmpdir, "Directory not removed (different proc)"); + + + $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; + $ipc_thread_clone->set_tid(undef); + $ipc_thread_clone = undef; + ok(-d $tmpdir, "Directory not removed (no thread)"); + + $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; + $ipc_fork_clone->set_pid(undef); + $ipc_fork_clone = undef; + ok(-d $tmpdir, "Directory not removed (no proc)"); + + $ipc = undef; + ok(!-d $tmpdir, "Directory removed"); +} + +{ + no warnings 'once'; + local *Test2::IPC::Driver::Files::abort = sub { + my $self = shift; + local $self->{no_fatal} = 1; + $self->Test2::IPC::Driver::abort(@_); + die 255; + }; + + my $tmpdir; + my @lines; + my $file = __FILE__; + + my $out = simple_capture { + local $ENV{T2_KEEP_TEMPDIR} = 1; + + my $ipc = Test2::IPC::Driver::Files->new(); + $tmpdir = $ipc->tempdir; + $ipc->add_hub($hid); + eval { $ipc->add_hub($hid) }; push @lines => __LINE__; + $ipc->send($hid, bless({ foo => 1 }, 'Foo')); + $ipc->cull($hid); + $ipc->drop_hub($hid); + eval { $ipc->drop_hub($hid) }; push @lines => __LINE__; + + # Make sure having a hub file sitting around does not throw things off + # in T2_KEEP_TEMPDIR + $ipc->add_hub($hid); + $ipc = undef; + 1; + }; + + my $cleanup = sub { + if (opendir(my $d, $tmpdir)) { + for my $f (readdir($d)) { + next if $f =~ m/^\.+$/; + next unless -f "$tmpdir/$f"; + unlink("$tmpdir/$f"); + } + } + rmdir($tmpdir) or warn "Could not remove temp dir '$tmpdir': $!"; + }; + $cleanup->(); + + is($out->{STDOUT}, "not ok - IPC Fatal Error\nnot ok - IPC Fatal Error\n", "printed "); + + like($out->{STDERR}, qr/IPC Temp Dir: \Q$tmpdir\E/m, "Got temp dir path"); + like($out->{STDERR}, qr/^# Not removing temp dir: \Q$tmpdir\E$/m, "Notice about not closing tempdir"); + + like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '$hid' already exists/m, "Got message for duplicate hub"); + like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '$hid' does not exist/m, "Cannot remove hub twice"); + + $out = simple_capture { + my $ipc = Test2::IPC::Driver::Files->new(); + $ipc->add_hub($hid); + my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); + my $e = eval { $ipc->send($hid, bless({glob => \*ok, trace => $trace}, 'Foo')); 1 }; + print STDERR $@ unless $e || $@ =~ m/^255/; + $ipc->drop_hub($hid); + }; + + like($out->{STDERR}, qr/IPC Fatal Error:/, "Got fatal error"); + like($out->{STDERR}, qr/There was an error writing an event/, "Explanation"); + like($out->{STDERR}, qr/Destination: $hid/, "Got dest"); + like($out->{STDERR}, qr/Origin PID:\s+$$/, "Got pid"); + like($out->{STDERR}, qr/Error: Can't store GLOB items/, "Got cause"); + + $out = simple_capture { + my $ipc = Test2::IPC::Driver::Files->new(); + local $@; + eval { $ipc->send($hid, bless({ foo => 1 }, 'Foo')) }; + print STDERR $@ unless $@ =~ m/^255/; + $ipc = undef; + }; + like($out->{STDERR}, qr/IPC Fatal Error: hub '$hid' is not available, failed to send event!/, "Cannot send to missing hub"); + + $out = simple_capture { + my $ipc = Test2::IPC::Driver::Files->new(); + $tmpdir = $ipc->tempdir; + $ipc->add_hub($hid); + $ipc->send($hid, bless({ foo => 1 }, 'Foo')); + local $@; + eval { $ipc->drop_hub($hid) }; + print STDERR $@ unless $@ =~ m/^255/; + }; + $cleanup->(); + like($out->{STDERR}, qr/IPC Fatal Error: Not all files from hub '$hid' have been collected/, "Leftover files"); + like($out->{STDERR}, qr/IPC Fatal Error: Leftover files in the directory \(.*\.ready\)/, "What file"); + + $out = simple_capture { + my $ipc = Test2::IPC::Driver::Files->new(); + $ipc->add_hub($hid); + + eval { $ipc->send($hid, { foo => 1 }) }; + print STDERR $@ unless $@ =~ m/^255/; + + eval { $ipc->send($hid, bless({ foo => 1 }, 'xxx')) }; + print STDERR $@ unless $@ =~ m/^255/; + }; + like($out->{STDERR}, qr/IPC Fatal Error: 'HASH\(.*\)' is not a blessed object/, "Cannot send unblessed objects"); + like($out->{STDERR}, qr/IPC Fatal Error: 'xxx=HASH\(.*\)' is not an event object!/, "Cannot send non-event objects"); + + + $ipc = Test2::IPC::Driver::Files->new(); + + my ($fh, $fn) = tempfile(); + print $fh "\n"; + close($fh); + + Storable::store({}, $fn); + $out = simple_capture { eval { $ipc->read_event_file($fn) } }; + like( + $out->{STDERR}, + qr/IPC Fatal Error: Got an unblessed object: 'HASH\(.*\)'/, + "Events must actually be events (must be blessed)" + ); + + Storable::store(bless({}, 'Test2::Event::FakeEvent'), $fn); + $out = simple_capture { eval { $ipc->read_event_file($fn) } }; + like( + $out->{STDERR}, + qr{IPC Fatal Error: Event has unknown type \(Test2::Event::FakeEvent\), tried to load 'Test2/Event/FakeEvent\.pm' but failed: Can't locate Test2/Event/FakeEvent\.pm}, + "Events must actually be events (not a real module)" + ); + + Storable::store(bless({}, 'Test2::API'), $fn); + $out = simple_capture { eval { $ipc->read_event_file($fn) } }; + like( + $out->{STDERR}, + qr{'Test2::API=HASH\(.*\)' is not a 'Test2::Event' object}, + "Events must actually be events (not an event type)" + ); + + Storable::store(bless({}, 'Foo'), $fn); + $out = simple_capture { + local @INC; + push @INC => ('t/lib', 'lib'); + eval { $ipc->read_event_file($fn) }; + }; + ok(!$out->{STDERR}, "no problem", $out->{STDERR}); + ok(!$out->{STDOUT}, "no problem", $out->{STDOUT}); + + unlink($fn); +} + +{ + my $ipc = Test2::IPC::Driver::Files->new(); + $ipc->add_hub($hid); + $ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL'); + $ipc->set_globals({}); + my @events = $ipc->cull($hid); + is_deeply( + \@events, + [ {global => 1} ], + "Got global event" + ); + + @events = $ipc->cull($hid); + ok(!@events, "Did not grab it again"); + + $ipc->set_globals({}); + @events = $ipc->cull($hid); + is_deeply( + \@events, + [ {global => 1} ], + "Still there" + ); + + $ipc->drop_hub($hid); + $ipc = undef; +} + +{ + my @list = shuffle ( + {global => 0, pid => 2, tid => 1, eid => 1}, + {global => 0, pid => 2, tid => 1, eid => 2}, + {global => 0, pid => 2, tid => 1, eid => 3}, + + {global => 1, pid => 1, tid => 1, eid => 1}, + {global => 1, pid => 12, tid => 1, eid => 3}, + {global => 1, pid => 11, tid => 1, eid => 2}, + + {global => 0, pid => 2, tid => 3, eid => 1}, + {global => 0, pid => 2, tid => 3, eid => 10}, + {global => 0, pid => 2, tid => 3, eid => 100}, + + {global => 0, pid => 5, tid => 3, eid => 2}, + {global => 0, pid => 5, tid => 3, eid => 20}, + {global => 0, pid => 5, tid => 3, eid => 200}, + ); + + my @sorted; + { + package Test2::IPC::Driver::Files; + @sorted = sort cmp_events @list; + } + + is_deeply( + \@sorted, + [ + {global => 1, pid => 1, tid => 1, eid => 1}, + {global => 1, pid => 11, tid => 1, eid => 2}, + {global => 1, pid => 12, tid => 1, eid => 3}, + + {global => 0, pid => 2, tid => 1, eid => 1}, + {global => 0, pid => 2, tid => 1, eid => 2}, + {global => 0, pid => 2, tid => 1, eid => 3}, + + {global => 0, pid => 2, tid => 3, eid => 1}, + {global => 0, pid => 2, tid => 3, eid => 10}, + {global => 0, pid => 2, tid => 3, eid => 100}, + + {global => 0, pid => 5, tid => 3, eid => 2}, + {global => 0, pid => 5, tid => 3, eid => 20}, + {global => 0, pid => 5, tid => 3, eid => 200}, + ], + "Sort by global, pid, tid and then eid" + ); +} + +{ + my $ipc = 'Test2::IPC::Driver::Files'; + + is_deeply( + $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo.ready.complete'), + { + ready => 1, + complete => 1, + global => 1, + type => "Event::Type::Foo", + hid => "GLOBAL", + pid => "123", + tid => "456", + eid => "789", + }, + "Parsed global complete" + ); + + is_deeply( + $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo.ready'), + { + ready => 1, + complete => 0, + global => 1, + type => "Event::Type::Foo", + hid => "GLOBAL", + pid => "123", + tid => "456", + eid => "789", + }, + "Parsed global ready" + ); + + is_deeply( + $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo'), + { + ready => 0, + complete => 0, + global => 1, + type => "Event::Type::Foo", + hid => "GLOBAL", + pid => "123", + tid => "456", + eid => "789", + }, + "Parsed global not ready" + ); + + is_deeply( + $ipc->parse_event_filename(join ipc_separator, qw'1 1 1 123 456 789 Event Type Foo.ready.complete'), + { + ready => 1, + complete => 1, + global => 0, + type => "Event::Type::Foo", + hid => "1${sep}1${sep}1", + pid => "123", + tid => "456", + eid => "789", + }, + "Parsed event complete" + ); + + is_deeply( + $ipc->parse_event_filename(join ipc_separator, qw'1 2 3 123 456 789 Event Type Foo.ready'), + { + ready => 1, + complete => 0, + global => 0, + type => "Event::Type::Foo", + hid => "1${sep}2${sep}3", + pid => "123", + tid => "456", + eid => "789", + }, + "Parsed event ready" + ); + + is_deeply( + $ipc->parse_event_filename(join ipc_separator, qw'3 2 11 123 456 789 Event'), + { + ready => 0, + complete => 0, + global => 0, + type => "Event", + hid => "3${sep}2${sep}11", + pid => "123", + tid => "456", + eid => "789", + }, + "Parsed event not ready" + ); +} + +{ + my $ipc = Test2::IPC::Driver::Files->new(); + + my $hid = join ipc_separator, qw"1 1 1"; + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready.complete") ? 1 : 0, + 0, + "Do not read complete global" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready") ? 1 : 0, + 1, + "Should read ready global the first time" + ); + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready") ? 1 : 0, + 0, + "Should not read ready global again" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo") ? 1 : 0, + 0, + "Should not read un-ready global" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready.complete") ? 1 : 0, + 0, + "Do not read complete our hid" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready") ? 1 : 0, + 1, + "Should read ready our hid" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready") ? 1 : 0, + 1, + "Should read ready our hid (again, no duplicate checking)" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo") ? 1 : 0, + 0, + "Should not read un-ready our hid" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo.ready.complete") ? 1 : 0, + 0, + "Not ours - complete" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo.ready") ? 1 : 0, + 0, + "Not ours - ready" + ); + + is_deeply( + $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo") ? 1 : 0, + 0, + "Not ours - unready" + ); + + my @got = $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo"); + ok(!@got, "return empty list for false"); + + @got = $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready"); + is(@got, 1, "got 1 item on true"); + + like(delete $got[0]->{full_path}, qr{^.+\Q$hid\E${sep}123${sep}456${sep}789${sep}Event${sep}Type${sep}Foo\.ready$}, "Got full path"); + is_deeply( + $got[0], + $ipc->parse_event_filename(join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready"), + "Apart from full_path we get entire parsed filename" + ); + + $ipc = undef; +} + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Tools/Tiny.t b/dist/Test-Simple/t/Test2/modules/Tools/Tiny.t new file mode 100644 index 00000000000..bdd941db179 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Tools/Tiny.t @@ -0,0 +1,210 @@ +use strict; +use warnings; + +use Test2::IPC; +use Test2::Tools::Tiny; + +use Test2::API qw/context intercept test2_stack/; + +ok(__PACKAGE__->can($_), "imported '$_\()'") for qw{ + ok + is isnt + like unlike + diag note + + is_deeply + + warnings + exception + + plan + skip_all + done_testing +}; + +ok(1, "'ok' Test"); +is("foo", "foo", "'is' test"); +is(undef, undef, "'is' undef test"); +isnt("foo", "bar", "'isnt' test"); +isnt("foo", undef, "'isnt' undef test 1"); +isnt(undef, "foo", "'isnt' undef test 2"); +like("foo", qr/o/, "'like' test"); +unlike("foo", qr/a/, "'unlike' test"); + +note("Testing Note"); + +my $str = "abc"; +is_deeply( + { a => 1, b => 2, c => { ref => \$str, obj => bless({x => 1}, 'XXX'), array => [1, 2, 3]}}, + { a => 1, b => 2, c => { ref => \$str, obj => {x => 1}, array => [1, 2, 3]}}, + "'is_deeply' test" +); + +is_deeply( + warnings { warn "aaa\n"; warn "bbb\n" }, + [ "aaa\n", "bbb\n" ], + "Got warnings" +); + +is_deeply( + warnings { 1 }, + [], + "no warnings" +); + +is(exception { die "foo\n" }, "foo\n", "got exception"); +is(exception { 1 }, undef, "no exception"); + +my $main_events = intercept { + plan 8; + + ok(0, "'ok' Test"); + is("foo", "bar", "'is' test"); + isnt("foo", "foo", "'isnt' test"); + like("foo", qr/a/, "'like' test"); + unlike("foo", qr/o/, "'unlike' test"); + + is_deeply( + { a => 1, b => 2, c => {}}, + { a => 1, b => 2, c => []}, + "'is_deeply' test" + ); +}; + +my $other_events = intercept { + diag("Testing Diag"); + note("Testing Note"); +}; + +my ($plan, $ok, $is, $isnt, $like, $unlike, $is_deeply) = grep {!$_->isa('Test2::Event::Diag')} @$main_events; +my ($diag, $note) = @$other_events; + +ok($plan->isa('Test2::Event::Plan'), "got plan"); +is($plan->max, 8, "planned for 8 oks"); + +ok($ok->isa('Test2::Event::Ok'), "got 'ok' result"); +is($ok->pass, 0, "'ok' test failed"); + +ok($is->isa('Test2::Event::Ok'), "got 'is' result"); +is($is->pass, 0, "'is' test failed"); + +ok($isnt->isa('Test2::Event::Ok'), "got 'isnt' result"); +is($isnt->pass, 0, "'isnt' test failed"); + +ok($like->isa('Test2::Event::Ok'), "got 'like' result"); +is($like->pass, 0, "'like' test failed"); + +ok($unlike->isa('Test2::Event::Ok'), "got 'unlike' result"); +is($unlike->pass, 0, "'unlike' test failed"); + +ok($is_deeply->isa('Test2::Event::Ok'), "got 'is_deeply' result"); +is($is_deeply->pass, 0, "'is_deeply' test failed"); + +ok($diag->isa('Test2::Event::Diag'), "got 'diag' result"); +is($diag->message, "Testing Diag", "got diag message"); + +ok($note->isa('Test2::Event::Note'), "got 'note' result"); +is($note->message, "Testing Note", "got note message"); + +my $events = intercept { + skip_all 'because'; + ok(0, "should not see me"); + die "should not happen"; +}; + +is(@$events, 1, "1 event"); +ok($events->[0]->isa('Test2::Event::Plan'), "got plan"); +is($events->[0]->directive, 'SKIP', "plan is skip"); +is($events->[0]->reason, 'because', "skip reason"); + +$events = intercept { + is(undef, ""); + is("", undef); + + isnt(undef, undef); + + like(undef, qr//); + unlike(undef, qr//); +}; + +@$events = grep {!$_->isa('Test2::Event::Diag')} @$events; +is(@$events, 5, "5 events"); +ok(!$_->pass, "undef test - should not pass") for @$events; + +sub tool { context() }; + +my %params; +my $ctx = context(level => -1); +my $ictx; +$events = intercept { + %params = @_; + + $ictx = tool(); + $ictx->ok(1, 'pass'); + $ictx->ok(0, 'fail'); + my $trace = Test2::Util::Trace->new( + frame => [ __PACKAGE__, __FILE__, __LINE__], + ); + $ictx->hub->finalize($trace, 1); +}; + +@$events = grep {!$_->isa('Test2::Event::Diag')} @$events; + +is_deeply( + \%params, + { + context => { %$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef }, + hub => $ictx->hub, + }, + "Passed in some useful params" +); + +ok($ctx != $ictx, "Different context inside intercept"); + +is(@$events, 3, "got 3 events"); + +$ctx->release; +$ictx->release; + +# Test that a bail-out in an intercept does not exit. +$events = intercept { + $ictx = tool(); + $ictx->bail("The world ends"); + $ictx->ok(0, "Should not see this"); +}; + +is(@$events, 1, "got 1 event"); +ok($events->[0]->isa('Test2::Event::Bail'), "got the bail"); + +$events = intercept { + $ictx = tool(); +}; + +$ictx->release; + +like( + exception { intercept { die 'foo' } }, + qr/foo/, + "Exception was propogated" +); + +$events = intercept { + test2_stack()->top->set_no_ending(0); + ok(1); +}; + +is(@$events, 2, "2 events"); +ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); +ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); + +$events = intercept { + test2_stack()->top->set_no_ending(0); + ok(1); + done_testing; +}; + +is(@$events, 2, "2 events"); +ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); +ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Util.t b/dist/Test-Simple/t/Test2/modules/Util.t new file mode 100644 index 00000000000..2bca8e300c4 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Util.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::Util qw/ + try + + get_tid USE_THREADS + + pkg_to_file + + CAN_FORK + CAN_THREAD + CAN_REALLY_FORK + + IS_WIN32 +/; + +{ + for my $try (\&try, Test2::Util->can('_manual_try'), Test2::Util->can('_local_try')) { + my ($ok, $err) = $try->(sub { die "xxx" }); + ok(!$ok, "cought exception"); + like($err, qr/xxx/, "expected exception"); + + ($ok, $err) = $try->(sub { 0 }); + ok($ok, "Success"); + ok(!$err, "no error"); + } +} + +is(pkg_to_file('A::Package::Name'), 'A/Package/Name.pm', "Converted package to file"); + +# Make sure running them does not die +# We cannot really do much to test these. +CAN_THREAD(); +CAN_FORK(); +CAN_REALLY_FORK(); +IS_WIN32(); + +is(IS_WIN32(), ($^O eq 'MSWin32') ? 1 : 0, "IS_WIN32 is correct ($^O)"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Util/ExternalMeta.t b/dist/Test-Simple/t/Test2/modules/Util/ExternalMeta.t new file mode 100644 index 00000000000..bd9812fc377 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Util/ExternalMeta.t @@ -0,0 +1,70 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +{ + package Foo::Bar; + + use Test2::Util::ExternalMeta; + use Test2::Util::HashBase qw/foo bar/; +} + +ok(Foo::Bar->can($_), "Imported '$_'") for qw/meta get_meta set_meta delete_meta/; + +my $one = Foo::Bar->new(foo => 1, bar => 2); +ok($one->isa('Foo::Bar'), "Got instance"); + +is_deeply($one, {foo => 1, bar => 2}, "nothing fishy.. yet"); + +is($one->get_meta('foo'), undef, "no meta-data for foo"); +is($one->get_meta('bar'), undef, "no meta-data for bar"); +is($one->get_meta('baz'), undef, "no meta-data for baz"); + +is($one->meta('foo'), undef, "no meta-data for foo"); +is($one->meta('bar'), undef, "no meta-data for bar"); +is($one->meta('baz'), undef, "no meta-data for baz"); + +is_deeply($one, {foo => 1, bar => 2}, "Still have not modified instance"); + +$one->set_meta('foo' => 123); +is($one->foo, 1, "did not change attribute"); +is($one->meta('foo'), 123, "get meta-data for foo"); +is($one->get_meta('foo'), 123, "get meta-data for foo again"); + +$one->meta('foo', 345); +is($one->foo, 1, "did not change attribute"); +is($one->meta('foo', 678), 123, "did not alter already set meta-attribute"); +is($one->get_meta('foo'), 123, "still did not alter already set meta-attribute"); + +is($one->meta('bar', 789), 789, "used default for bar"); +is($one->bar, 2, "did not change attribute"); + +is_deeply( + $one, + { + foo => 1, + bar => 2, + Test2::Util::ExternalMeta::META_KEY() => { + foo => 123, + bar => 789, + }, + }, + "Stored meta-data" +); + +is($one->delete_meta('foo'), 123, "got old value on delete"); +is($one->meta('foo'), undef, "no more value"); + +is_deeply( + $one, + { + foo => 1, + bar => 2, + Test2::Util::ExternalMeta::META_KEY() => { + bar => 789, + }, + }, + "Deleted the meta key" +); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/modules/Util/HashBase.t b/dist/Test-Simple/t/Test2/modules/Util/HashBase.t new file mode 100644 index 00000000000..7f1824ae164 --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Util/HashBase.t @@ -0,0 +1,157 @@ +use strict; +use warnings; + +use Test::More; + + +sub warnings(&) { + my $code = shift; + my @warnings; + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $code->(); + return \@warnings; +} + +sub exception(&) { + my $code = shift; + local ($@, $!, $SIG{__DIE__}); + my $ok = eval { $code->(); 1 }; + my $error = $@ || 'SQUASHED ERROR'; + return $ok ? undef : $error; +} + +BEGIN { + $INC{'Object/HashBase/Test/HBase.pm'} = __FILE__; + + package + main::HBase; + use Test2::Util::HashBase qw/foo bar baz/; + + main::is(FOO, 'foo', "FOO CONSTANT"); + main::is(BAR, 'bar', "BAR CONSTANT"); + main::is(BAZ, 'baz', "BAZ CONSTANT"); +} + +BEGIN { + package + main::HBaseSub; + use base 'main::HBase'; + use Test2::Util::HashBase qw/apple pear/; + + main::is(FOO, 'foo', "FOO CONSTANT"); + main::is(BAR, 'bar', "BAR CONSTANT"); + main::is(BAZ, 'baz', "BAZ CONSTANT"); + main::is(APPLE, 'apple', "APPLE CONSTANT"); + main::is(PEAR, 'pear', "PEAR CONSTANT"); +} + +my $one = main::HBase->new(foo => 'a', bar => 'b', baz => '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, + { + foo => undef, + bar => 'b', + baz => 'c', + }, + 'hash' +); + +BEGIN { + package + main::Const::Test; + use Test2::Util::HashBase qw/foo/; + + sub do_it { + if (FOO()) { + return 'const'; + } + return 'not const' + } +} + +my $pkg = 'main::Const::Test'; +is($pkg->do_it, 'const', "worked as expected"); +{ + local $SIG{__WARN__} = sub { }; + *main::Const::Test::FOO = sub { 0 }; +} +ok(!$pkg->FOO, "overrode const sub"); +is($pkg->do_it, 'const', "worked as expected, const was constant"); + +BEGIN { + $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__; + + package + main::HBase::Wrapped; + use Test2::Util::HashBase qw/foo bar/; + + my $foo = __PACKAGE__->can('foo'); + no warnings 'redefine'; + *foo = sub { + my $self = shift; + $self->set_bar(1); + $self->$foo(@_); + }; +} + +BEGIN { + $INC{'Object/HashBase/Test/HBase/Wrapped/Inherit.pm'} = __FILE__; + + package + main::HBase::Wrapped::Inherit; + use base 'main::HBase::Wrapped'; + use Test2::Util::HashBase; +} + +my $o = main::HBase::Wrapped::Inherit->new(foo => 1); +my $foo = $o->foo; +is($o->bar, 1, 'parent attribute sub not overridden'); + +{ + package + Foo; + + sub new; + + use Test2::Util::HashBase qw/foo bar baz/; + + sub new { 'foo' }; +} + +is(Foo->new, 'foo', "Did not override existing 'new' method"); + +BEGIN { + $INC{'Object/HashBase/Test/HBase2.pm'} = __FILE__; + + package + main::HBase2; + use Test2::Util::HashBase qw/foo -bar ^baz/; + + main::is(FOO, 'foo', "FOO CONSTANT"); + main::is(BAR, 'bar', "BAR CONSTANT"); + main::is(BAZ, 'baz', "BAZ CONSTANT"); +} + +my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz'); +is($ro->foo, 'foo', "got foo"); +is($ro->bar, 'bar', "got bar"); +is($ro->baz, 'baz', "got baz"); + +is($ro->set_foo('xxx'), 'xxx', "Can set foo"); +is($ro->foo, 'xxx', "got foo"); + +like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar"); + +my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') }; +like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning"); + +done_testing; + +1; diff --git a/dist/Test-Simple/t/Test2/modules/Util/Trace.t b/dist/Test-Simple/t/Test2/modules/Util/Trace.t new file mode 100644 index 00000000000..1f87033a4cb --- /dev/null +++ b/dist/Test-Simple/t/Test2/modules/Util/Trace.t @@ -0,0 +1,41 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; +use Test2::Util::Trace; + +like( + exception { 'Test2::Util::Trace'->new() }, + qr/The 'frame' attribute is required/, + "got error" +); + +my $one = 'Test2::Util::Trace'->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); +is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); +is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); +is($one->package, 'Foo::Bar', "Got package"); +is($one->file, 'foo.t', "Got file"); +is($one->line, 5, "Got line"); +is($one->subname, 'Foo::Bar::foo', "got subname"); + +is($one->debug, "at foo.t line 5", "got trace"); +$one->set_detail("yo momma"); +is($one->debug, "yo momma", "got detail for trace"); +$one->set_detail(undef); + +is( + exception { $one->throw('I died') }, + "I died at foo.t line 5.\n", + "got exception" +); + +is_deeply( + warnings { $one->alert('I cried') }, + [ "I cried at foo.t line 5.\n" ], + "alter() warns" +); + +my $snap = $one->snapshot; +is_deeply($snap, $one, "identical"); +ok($snap != $one, "Not the same instance"); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/regression/693_ipc_ordering.t b/dist/Test-Simple/t/Test2/regression/693_ipc_ordering.t new file mode 100644 index 00000000000..55116da6ec3 --- /dev/null +++ b/dist/Test-Simple/t/Test2/regression/693_ipc_ordering.t @@ -0,0 +1,30 @@ +use Test2::Tools::Tiny; +use strict; +use warnings; + +skip_all("Test cannot run on perls below 5.8.8") unless "$]" > 5.008007; + +use Test2::Util qw/CAN_THREAD/; +use Test2::IPC; +use Test2::API qw/context intercept/; + +skip_all('System does not have threads') unless CAN_THREAD(); + +require threads; +threads->import; + +my $events = intercept { + threads->create( + sub { + ok 1, "something $_ nonlocal" for (1 .. 15); + } + )->join; +}; + +is_deeply( + [map { $_->{name} } @$events], + [map "something $_ nonlocal", 1 .. 15], + "Culled sub-thread events in correct order" +); + +done_testing; diff --git a/dist/Test-Simple/t/Test2/regression/746-forking-subtest.t b/dist/Test-Simple/t/Test2/regression/746-forking-subtest.t new file mode 100644 index 00000000000..bd056ed1bb4 --- /dev/null +++ b/dist/Test-Simple/t/Test2/regression/746-forking-subtest.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test2::IPC; +use Test2::Tools::Tiny; +use Test2::API qw/context intercept test2_stack/; +use Test2::Util qw/CAN_FORK/; + +BEGIN { + skip_all "System cannot fork" unless CAN_FORK; +} + +my $events = intercept { + Test2::API::run_subtest("this subtest forks" => sub { + if (fork) { + wait; + isnt($?, 0, "subprocess died"); + } else { + # Prevent the exception from being rendered to STDERR, people have + # complained about STDERR noise in tests before. + close STDERR; + die "# Expected warning from subtest"; + }; + }, {no_fork => 1}); +}; + +my @subtests = grep {; $_->isa('Test2::Event::Subtest') } @$events; + +if (is(@subtests, 1, "only one subtest run, effectively")) { + my @subokay = grep {; $_->isa('Test2::Event::Ok') } + @{ $subtests[0]->subevents }; + is(@subokay, 1, "we got one test result inside the subtest"); + ok(! $subokay[0]->causes_fail, "...and it passed"); +} else { + # give up, we're already clearly broken +} + +done_testing; diff --git a/dist/Test-Simple/t/Test2/regression/gh_16.t b/dist/Test-Simple/t/Test2/regression/gh_16.t new file mode 100644 index 00000000000..45e4cd7b769 --- /dev/null +++ b/dist/Test-Simple/t/Test2/regression/gh_16.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +# This test is for gh #16 +# Also see https://rt.perl.org/Public/Bug/Display.html?id=127774 + +# Ceate this END before anything else so that $? gets set to 0 +END { $? = 0 } + +BEGIN { + print "\n1..1\n"; + close(STDERR); + open(STDERR, '>&', STDOUT); +} + +use Test2::API; + +eval(' sub { die "xxx" } ')->(); +END { + sub { my $ctx = Test2::API::context(); $ctx->release; }->(); + print "ok 1 - Did not segv\n"; + $? = 0; +} diff --git a/dist/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t b/dist/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t new file mode 100644 index 00000000000..a2964fd4026 --- /dev/null +++ b/dist/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t @@ -0,0 +1,62 @@ +use strict; +use warnings; +use Test2::IPC; +use Test2::Tools::Tiny; +use Test2::API qw/context test2_stack/; +use Test2::Util qw/CAN_FORK/; + +BEGIN { + skip_all "System cannot fork" unless CAN_FORK; +} + +plan(3); + +pipe(my ($read, $write)); + +test2_stack()->top; +my $hub = test2_stack()->new_hub(); + +my $pid = fork(); +die "Failed to fork" unless defined $pid; + +if ($pid) { + close($read); + test2_stack()->pop($hub); + $hub = undef; + print $write "Go\n"; + close($write); + waitpid($pid, 0); + my $err = $? >> 8; + is($err, 255, "Exit code was not masked"); + ok($err != 100, "Did not hit the safety exit"); +} +else { + close($write); + my $ignore = <$read>; + close($read); + close(STDERR); + close(STDOUT); + open(STDERR, '>', my $x); + my $ctx = context(hub => $hub, level => -1); + my $clone = $ctx->snapshot; + $ctx->release; + $clone->ok(0, "Should not see this"); + print STDERR "\n\nSomething went wrong!!!!\n\n"; + exit 100; # Safety exit +}; + + +# The rest of this is to make sure nothing that happens when reading the event +# messes with $?. + +pipe($read, $write); + +$pid = fork; +die "Failed to fork" unless defined $pid; + +unless($pid) { + my $ignore = <$read>; + ok(1, "Test in forked process"); +} + +print $write "Go\n"; diff --git a/dist/Test-Simple/t/dependents.t b/dist/Test-Simple/t/dependents.t deleted file mode 100644 index 90e8938ebe7..00000000000 --- a/dist/Test-Simple/t/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/dist/Test-Simple/t/fork.t b/dist/Test-Simple/t/fork.t deleted file mode 100644 index 6730a2dad1e..00000000000 --- a/dist/Test-Simple/t/fork.t +++ /dev/null @@ -1,31 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - @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/dist/Test-Simple/t/MyTest.pm b/dist/Test-Simple/t/lib/MyTest.pm similarity index 100% rename from dist/Test-Simple/t/MyTest.pm rename to dist/Test-Simple/t/lib/MyTest.pm diff --git a/dist/Test-Simple/t/lib/SkipAll.pm b/dist/Test-Simple/t/lib/SkipAll.pm new file mode 100644 index 00000000000..4c9e5116d23 --- /dev/null +++ b/dist/Test-Simple/t/lib/SkipAll.pm @@ -0,0 +1,7 @@ +package SkipAll; +use strict; +use warnings; + +main::skip_all("foo"); + +1; diff --git a/dist/Test-Simple/t/SmallTest.pm b/dist/Test-Simple/t/lib/SmallTest.pm similarity index 100% rename from dist/Test-Simple/t/SmallTest.pm rename to dist/Test-Simple/t/lib/SmallTest.pm diff --git a/dist/Test-Simple/t/regression/642_persistent_end.t b/dist/Test-Simple/t/regression/642_persistent_end.t new file mode 100644 index 00000000000..b1282638480 --- /dev/null +++ b/dist/Test-Simple/t/regression/642_persistent_end.t @@ -0,0 +1,25 @@ +use Test::More; +use strict; +use warnings; + +use Test2::API qw{ + test2_set_is_end + test2_get_is_end + intercept +}; + +my %res; +intercept { + my $tb = Test::Builder->new; + $res{before} = test2_get_is_end(); + test2_set_is_end(); + $res{isset} = test2_get_is_end(); + $tb->reset; + $res{reset} = test2_get_is_end(); +}; + +ok(!$res{before}, "Not the end"); +ok($res{isset}, "the end"); +ok(!$res{reset}, "Not the end"); + +done_testing; diff --git a/dist/Test-Simple/t/regression/662-tbt-no-plan.t b/dist/Test-Simple/t/regression/662-tbt-no-plan.t new file mode 100644 index 00000000000..acc9c9fc1bd --- /dev/null +++ b/dist/Test-Simple/t/regression/662-tbt-no-plan.t @@ -0,0 +1,25 @@ +use Test::Builder::Tester; +use Test::More tests => 1; +use strict; +use warnings; + +BEGIN { + package Example::Tester; + + use base 'Test::Builder::Module'; + $INC{'Example/Tester.pm'} = 1; + + sub import { + my $package = shift; + my %args = @_; + my $callerpack = caller; + my $tb = __PACKAGE__->builder; + $tb->exported_to($callerpack); + local $SIG{__WARN__} = sub { }; + $tb->no_plan; + } +} + +test_out('ok 1 - use Example::Tester;'); +use_ok('Example::Tester'); +test_test("use Example::Tester;"); diff --git a/dist/Test-Simple/t/regression/684-nested_todo_diag.t b/dist/Test-Simple/t/regression/684-nested_todo_diag.t new file mode 100644 index 00000000000..cccd27e8792 --- /dev/null +++ b/dist/Test-Simple/t/regression/684-nested_todo_diag.t @@ -0,0 +1,23 @@ +use Test::More; +use strict; +use warnings; + +use Test2::API qw/intercept/; +my @events; + +intercept { + local $TODO = "broken"; + + Test2::API::test2_stack->top->listen(sub { push @events => $_[1] }, inherit => 1); + + subtest foo => sub { + subtest bar => sub { + ok(0, 'oops'); + }; + }; +}; + +my ($event) = grep { $_->trace->line == 16 && ref($_) eq 'Test::Builder::TodoDiag'} @events; +ok($event, "nested todo diag on line 16 was changed to TodoDiag (STDOUT instead of STDERR)"); + +done_testing; diff --git a/dist/Test-Simple/t/regression/694_note_diag_return_values.t b/dist/Test-Simple/t/regression/694_note_diag_return_values.t new file mode 100644 index 00000000000..0c72a6f4449 --- /dev/null +++ b/dist/Test-Simple/t/regression/694_note_diag_return_values.t @@ -0,0 +1,20 @@ +use Test::More; +use strict; +use warnings; + +use Test2::API qw/intercept/; + +my @returns; +intercept { + push @returns => diag('foo'); + push @returns => note('foo'); + + my $tb = Test::Builder->new; + push @returns => $tb->diag('foo'); + push @returns => $tb->note('foo'); +}; + +is(@returns, 4, "4 return values"); +is_deeply(\@returns, [0, 0, 0, 0], "All note/diag returns are 0"); + +done_testing; diff --git a/dist/Test-Simple/t/regression/696-intercept_skip_all.t b/dist/Test-Simple/t/regression/696-intercept_skip_all.t new file mode 100644 index 00000000000..1362e1046f3 --- /dev/null +++ b/dist/Test-Simple/t/regression/696-intercept_skip_all.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/intercept/; + +tests in_eval => sub { + my $events = intercept { + eval { skip_all "foo" }; + die "Should not see this: $@"; + }; + + is(@$events, 1, "got 1 event"); + ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); + is($events->[0]->directive, 'SKIP', "Plan is to skip"); +}; + +tests no_eval => sub { + my $events = intercept { + skip_all "foo"; + die "Should not see this: $@"; + }; + + is(@$events, 1, "got 1 event"); + ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); + is($events->[0]->directive, 'SKIP', "Plan is to skip"); +}; + +tests in_require => sub { + my $events = intercept { + require 't/lib/SkipAll.pm'; + die "Should not see this: $@"; + }; + + is(@$events, 1, "got 1 event"); + ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); + is($events->[0]->directive, 'SKIP', "Plan is to skip"); +}; + +done_testing; diff --git a/dist/Test-Simple/t/regression/721-nested-streamed-subtest.t b/dist/Test-Simple/t/regression/721-nested-streamed-subtest.t new file mode 100644 index 00000000000..b97e0e6a03e --- /dev/null +++ b/dist/Test-Simple/t/regression/721-nested-streamed-subtest.t @@ -0,0 +1,96 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +# This module's exports interfere with the ones in t/tools.pl +use Test::More (); +use Test2::API qw/run_subtest test2_stack/; + +{ + test2_stack->top; + my $temp_hub = test2_stack->new_hub(); + + my $output = capture { + run_subtest( + 'parent', + sub { + run_subtest( + 'buffered', + sub { + ok(1, 'b1'); + ok(1, 'b2'); + }, + {buffered => 1}, + ); + run_subtest( + 'streamed', + sub { + ok(1, 's1'); + ok(1, 's2'); + }, + {buffered => 0}, + ); + }, + {buffered => 1}, + ); + }; + + test2_stack->pop($temp_hub); + + Test::More::subtest( + 'Test2::API::run_subtest', + sub { + is($output->{STDERR}, q{}, 'no output on stderr'); + like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); + like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); + } + ); +} + +{ + test2_stack->top; + my $temp_hub = test2_stack->new_hub(); + + my $output = capture { + run_subtest( + 'parent', + sub { + run_subtest( + 'buffered', + sub { + ok(1, 'b1'); + ok(1, 'b2'); + }, + {buffered => 1}, + ); + Test::More::subtest( + 'streamed', + sub { + ok(1, 's1'); + ok(1, 's2'); + }, + {buffered => 0}, + ); + }, + {buffered => 1}, + ); + }; + + test2_stack->pop($temp_hub); + + Test::More::subtest( + 'Test::More::subtest and Test2::API::run_subtest', + sub { + is($output->{STDERR}, q{}, 'no output on stderr'); + like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); + like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); + } + ); +} + +done_testing; diff --git a/dist/Test-Simple/t/regression/no_name_in_subtest.t b/dist/Test-Simple/t/regression/no_name_in_subtest.t new file mode 100644 index 00000000000..e332bb5abd8 --- /dev/null +++ b/dist/Test-Simple/t/regression/no_name_in_subtest.t @@ -0,0 +1,13 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +ok(1, ""); + +tests foo => sub { + ok(1, "name"); + ok(1, ""); +}; + +done_testing; diff --git a/dist/Test-Simple/t/subtest/exceptions.t b/dist/Test-Simple/t/subtest/exceptions.t deleted file mode 100644 index 92d65b648a2..00000000000 --- a/dist/Test-Simple/t/subtest/exceptions.t +++ /dev/null @@ -1,63 +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; - $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/dist/Test-Simple/t/subtest/fork.t b/dist/Test-Simple/t/subtest/fork.t deleted file mode 100644 index 3b1904f16e4..00000000000 --- a/dist/Test-Simple/t/subtest/fork.t +++ /dev/null @@ -1,51 +0,0 @@ -#!/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/lib/.gitignore b/lib/.gitignore index 57b02a0b17b..eb8733fe205 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -184,6 +184,8 @@ /Term/ /Test.pm /Test/ +/Test2.pm +/Test2/ /Text/ /Thread/ /Tie/File.pm diff --git a/win32/Makefile b/win32/Makefile index fff30785318..5654382be90 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -1430,6 +1430,7 @@ distclean: realclean -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP -if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term -if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test + -if exist $(LIBDIR)\Test2 rmdir /s /q $(LIBDIR)\Test2 -if exist $(LIBDIR)\Text rmdir /s /q $(LIBDIR)\Text -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread -if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads diff --git a/win32/makefile.mk b/win32/makefile.mk index c212ea2dad2..fcbfbe729e7 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -1748,6 +1748,7 @@ distclean: realclean -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP -if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term -if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test + -if exist $(LIBDIR)\Test2 rmdir /s /q $(LIBDIR)\Test2 -if exist $(LIBDIR)\Text rmdir /s /q $(LIBDIR)\Text -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread -if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads