diff --git a/MANIFEST b/MANIFEST index 6e9637878e18..e7c146a8ab1e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2863,6 +2863,249 @@ cpan/Test-Simple/t/Test2/regression/693_ipc_ordering.t Test file related to T cpan/Test-Simple/t/Test2/regression/746-forking-subtest.t Test file related to Test::Simple cpan/Test-Simple/t/Test2/regression/gh_16.t Test file related to Test::Simple cpan/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t Test file related to Test::Simple +cpan/Test2-Suite/lib/Test2/AsyncSubtest.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Attach.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Detach.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/AsyncSubtest/Formatter.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/AsyncSubtest/Hub.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Bundle.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Bundle/Extended.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Bundle/More.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Bundle/Simple.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Array.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Bag.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Base.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Bool.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Custom.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/DeepRef.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Delta.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Event.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/EventMeta.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Float.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Hash.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Isa.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Meta.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Negatable.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Number.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Object.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/OrderedSubset.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Pattern.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Ref.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Regex.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Scalar.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Set.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/String.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Undef.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Compare/Wildcard.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy/API.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Context.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy/EndToEnd.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Event.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Hubs.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy/IPC.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Utilities.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Concurrency.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Contributing.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Testing.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Testing/Introduction.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Testing/Migrating.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Testing/Planning.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Testing/Todo.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/FirstTool.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Formatter.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Nesting.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestExit.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestingDone.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Subtest.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/TestBuilder.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Manual/Tooling/Testing.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Mock.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Plugin.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Plugin/BailOnFail.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Plugin/DieOnFail.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Plugin/ExitSummary.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Plugin/SRand.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Plugin/Times.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Plugin/UTF8.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require/AuthorTesting.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require/EnvVar.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require/Fork.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require/Module.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require/Perl.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require/RealFork.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Require/Threads.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Suite.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Todo.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/AsyncSubtest.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Basic.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Class.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/ClassicCompare.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Compare.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Defer.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Encoding.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Event.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Exception.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Exports.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/GenTemp.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Grab.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Mock.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Ref.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Refcount.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Spec.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Subtest.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Target.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Tester.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Tools/Warnings.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Grabber.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Guard.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Importer.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Ref.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Stash.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Sub.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Table.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Table/Cell.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Table/LineBreak.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Term.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Util/Times.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/V0.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Workflow.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Workflow/BlockBase.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Workflow/Build.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Workflow/Runner.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Workflow/Task.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Workflow/Task/Action.pm Test2-Suite +cpan/Test2-Suite/lib/Test2/Workflow/Task/Group.pm Test2-Suite +cpan/Test2-Suite/t/acceptance/OO.t Test2-Suite +cpan/Test2-Suite/t/acceptance/skip.t Test2-Suite +cpan/Test2-Suite/t/acceptance/spec.t Test2-Suite +cpan/Test2-Suite/t/acceptance/Tools.t Test2-Suite +cpan/Test2-Suite/t/acceptance/Workflow-Acceptance.t Test2-Suite +cpan/Test2-Suite/t/acceptance/Workflow-Acceptance2.t Test2-Suite +cpan/Test2-Suite/t/acceptance/Workflow-Acceptance3.t Test2-Suite +cpan/Test2-Suite/t/acceptance/Workflow-Acceptance4.t Test2-Suite +cpan/Test2-Suite/t/acceptance/Workflow-Acceptance5.t Test2-Suite +cpan/Test2-Suite/t/behavior/async_trace.t Test2-Suite +cpan/Test2-Suite/t/behavior/filtering.t Test2-Suite +cpan/Test2-Suite/t/behavior/Mocking.t Test2-Suite +cpan/Test2-Suite/t/behavior/no_done_testing.t Test2-Suite +cpan/Test2-Suite/t/behavior/no_leaks_any.t Test2-Suite +cpan/Test2-Suite/t/behavior/no_leaks_no_fork.t Test2-Suite +cpan/Test2-Suite/t/behavior/no_leaks_no_iso.t Test2-Suite +cpan/Test2-Suite/t/behavior/no_leaks_no_threads.t Test2-Suite +cpan/Test2-Suite/t/behavior/simple.t Test2-Suite +cpan/Test2-Suite/t/lib/MyTest/Target.pm Test2-Suite +cpan/Test2-Suite/t/load_manual.t Test2-Suite +cpan/Test2-Suite/t/modules/AsyncSubtest.t Test2-Suite +cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Attach.t Test2-Suite +cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Detach.t Test2-Suite +cpan/Test2-Suite/t/modules/AsyncSubtest/Hub.t Test2-Suite +cpan/Test2-Suite/t/modules/Bundle.t Test2-Suite +cpan/Test2-Suite/t/modules/Bundle/Extended.t Test2-Suite +cpan/Test2-Suite/t/modules/Bundle/More.t Test2-Suite +cpan/Test2-Suite/t/modules/Bundle/Simple.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Array.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Bag.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Base.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Bool.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Custom.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Delta.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Event.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/EventMeta.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Float.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Hash.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Isa.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Meta.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Number.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Object.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/OrderedSubset.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Pattern.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Ref.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Regex.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Scalar.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Set.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/String.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Undef.t Test2-Suite +cpan/Test2-Suite/t/modules/Compare/Wildcard.t Test2-Suite +cpan/Test2-Suite/t/modules/Mock.t Test2-Suite +cpan/Test2-Suite/t/modules/Plugin.t Test2-Suite +cpan/Test2-Suite/t/modules/Plugin/BailOnFail.t Test2-Suite +cpan/Test2-Suite/t/modules/Plugin/DieOnFail.t Test2-Suite +cpan/Test2-Suite/t/modules/Plugin/ExitSummary.t Test2-Suite +cpan/Test2-Suite/t/modules/Plugin/SRand.t Test2-Suite +cpan/Test2-Suite/t/modules/Plugin/Times.t Test2-Suite +cpan/Test2-Suite/t/modules/Plugin/UTF8.t Test2-Suite +cpan/Test2-Suite/t/modules/Require.t Test2-Suite +cpan/Test2-Suite/t/modules/Require/AuthorTesting.t Test2-Suite +cpan/Test2-Suite/t/modules/Require/EnvVar.t Test2-Suite +cpan/Test2-Suite/t/modules/Require/Fork.t Test2-Suite +cpan/Test2-Suite/t/modules/Require/Module.t Test2-Suite +cpan/Test2-Suite/t/modules/Require/Perl.t Test2-Suite +cpan/Test2-Suite/t/modules/Require/RealFork.t Test2-Suite +cpan/Test2-Suite/t/modules/Require/Threads.t Test2-Suite +cpan/Test2-Suite/t/modules/Suite.t Test2-Suite +cpan/Test2-Suite/t/modules/Todo.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/AsyncSubtest.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Basic.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Class.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/ClassicCompare.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/ClassicCompare2.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Compare.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Defer.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Encoding.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Event.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Exception.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Exports.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/GenTemp.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Grab.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Mock.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Ref.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Spec.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Subtest.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Target.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Test-Refcount/01count.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Test-Refcount/02one.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Test-Refcount/03weak.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Test-Refcount/04reftypes.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Tester.t Test2-Suite +cpan/Test2-Suite/t/modules/Tools/Warnings.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Grabber.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Ref.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Stash.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Sub.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Table.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Table/Cell.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Table/LineBreak.t Test2-Suite +cpan/Test2-Suite/t/modules/Util/Times.t Test2-Suite +cpan/Test2-Suite/t/modules/V0.t Test2-Suite +cpan/Test2-Suite/t/modules/Workflow.t Test2-Suite +cpan/Test2-Suite/t/modules/Workflow/BlockBase.t Test2-Suite +cpan/Test2-Suite/t/modules/Workflow/Build.t Test2-Suite +cpan/Test2-Suite/t/modules/Workflow/Runner.t Test2-Suite +cpan/Test2-Suite/t/modules/Workflow/Task.t Test2-Suite +cpan/Test2-Suite/t/modules/Workflow/Task/Action.t Test2-Suite +cpan/Test2-Suite/t/modules/Workflow/Task/Group.t Test2-Suite +cpan/Test2-Suite/t/regression/10-set_and_dne.t Test2-Suite +cpan/Test2-Suite/t/regression/132-bool.t Test2-Suite +cpan/Test2-Suite/t/regression/247_check_ref_bool.t Test2-Suite +cpan/Test2-Suite/t/regression/27-1-Test2-Bundle-More.t Test2-Suite +cpan/Test2-Suite/t/regression/27-2-Test2-Tools-Compare.t Test2-Suite +cpan/Test2-Suite/t/regression/27-3-Test2-Tools-ClassicCompare.t Test2-Suite +cpan/Test2-Suite/t/regression/43-bag-on-empty.t Test2-Suite +cpan/Test2-Suite/t/regression/async_subtest_missing_parent.t Test2-Suite +cpan/Test2-Suite/t/regression/Test2-Mock.t Test2-Suite +cpan/Test2-Suite/t/regression/Test2-Tools-Class.t Test2-Suite +cpan/Test2-Suite/t/regression/todo_and_facets.t Test2-Suite +cpan/Test2-Suite/t/regression/utf8-mock.t Test2-Suite cpan/Text-Balanced/lib/Text/Balanced.pm Text::Balanced cpan/Text-Balanced/t/01_compile.t See if Text::Balanced works cpan/Text-Balanced/t/02_extbrk.t See if Text::Balanced works diff --git a/Makefile.SH b/Makefile.SH index 2c24c66e738b..a7da7f0191fd 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -1412,33 +1412,39 @@ _cleaner2: -rmdir lib/autodie/exception lib/autodie/Scope lib/autodie lib/XS -rmdir lib/Win32API lib/VMS lib/Unicode/Collate/Locale -rmdir lib/Unicode/Collate/CJK lib/Unicode/Collate lib/Tie/Hash - -rmdir lib/Thread lib/Text lib/Test2/Util lib/Test2/Tools - -rmdir lib/Test2/IPC/Driver lib/Test2/IPC lib/Test2/Hub/Interceptor - -rmdir lib/Test2/Hub lib/Test2/Formatter lib/Test2/EventFacet/Info - -rmdir lib/Test2/EventFacet lib/Test2/Event/TAP lib/Test2/Event - -rmdir lib/Test2/API/InterceptResult lib/Test2/API lib/Test2 - -rmdir lib/Test/use lib/Test/Tester lib/Test/Builder/Tester - -rmdir lib/Test/Builder/IO lib/Test/Builder lib/Test lib/Term/Table - -rmdir lib/Term 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/Search lib/Scalar lib/Pod/Text lib/Pod/Simple - -rmdir lib/Pod/Perldoc lib/Pod/Html lib/PerlIO/via lib/PerlIO lib/Perl - -rmdir lib/Parse/CPAN lib/Parse lib/Params lib/Net/FTP lib/Module/Load - -rmdir lib/Module/CoreList lib/Module lib/Memoize lib/Math/BigRat - -rmdir lib/Math/BigInt lib/Math/BigFloat lib/Math lib/MIME - -rmdir lib/Locale/Maketext lib/Locale lib/List/Util lib/List - -rmdir lib/JSON/PP lib/JSON 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 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 lib/ExtUtils/Typemaps - -rmdir lib/ExtUtils/ParseXS lib/ExtUtils/MakeMaker/version - -rmdir lib/ExtUtils/MakeMaker lib/ExtUtils/Liblist - -rmdir lib/ExtUtils/Constant lib/ExtUtils/Command + -rmdir lib/Thread lib/Text lib/Test2/Workflow/Task lib/Test2/Workflow + -rmdir lib/Test2/Util/Table lib/Test2/Util lib/Test2/Tools + -rmdir lib/Test2/Require lib/Test2/Plugin + -rmdir lib/Test2/Manual/Tooling/Plugin lib/Test2/Manual/Tooling + -rmdir lib/Test2/Manual/Testing lib/Test2/Manual/Anatomy + -rmdir lib/Test2/Manual lib/Test2/IPC/Driver lib/Test2/IPC + -rmdir lib/Test2/Hub/Interceptor lib/Test2/Hub lib/Test2/Formatter + -rmdir lib/Test2/EventFacet/Info lib/Test2/EventFacet + -rmdir lib/Test2/Event/TAP lib/Test2/Event lib/Test2/Compare + -rmdir lib/Test2/Bundle lib/Test2/AsyncSubtest/Event + -rmdir lib/Test2/AsyncSubtest lib/Test2/API/InterceptResult + -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/Table 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/Search lib/Scalar + -rmdir lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc lib/Pod/Html + -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/BigRat lib/Math/BigInt + -rmdir lib/Math/BigFloat lib/Math lib/MIME lib/Locale/Maketext + -rmdir lib/Locale lib/List/Util lib/List lib/JSON/PP lib/JSON lib/IPC + -rmdir lib/IO/Uncompress/Adapter lib/IO/Uncompress lib/IO/Socket + -rmdir lib/IO/Compress/Zlib 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 lib/ExtUtils/Command -rmdir lib/ExtUtils/CBuilder/Platform/Windows -rmdir lib/ExtUtils/CBuilder/Platform lib/ExtUtils/CBuilder -rmdir lib/Exporter lib/Encode/Unicode lib/Encode/MIME/Header diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 2af4727b5518..0193914e8b85 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1129,6 +1129,17 @@ package Maintainers; ], }, + 'Test2::Suite' => { + 'DISTRIBUTION' => 'EXODIST/Test2-Suite-0.000156.tar.gz', + 'SYNCINFO' => 'LeoNerd on Wed Sep 14 10:44:29 2023', + 'FILES' => q[cpan/Test2-Suite], + 'EXCLUDED' => [ + qw( appveyor.yml + perltidyrc + t/00-report.t ), + ], + }, + 'Text::Abbrev' => { 'DISTRIBUTION' => 'FLORA/Text-Abbrev-1.02.tar.gz', 'FILES' => q[dist/Text-Abbrev], diff --git a/cpan/Test2-Suite/lib/Test2/AsyncSubtest.pm b/cpan/Test2-Suite/lib/Test2/AsyncSubtest.pm new file mode 100644 index 000000000000..9f7e10b69837 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/AsyncSubtest.pm @@ -0,0 +1,823 @@ +package Test2::AsyncSubtest; +use strict; +use warnings; + +use Test2::IPC; + +our $VERSION = '0.000156'; + +our @CARP_NOT = qw/Test2::Util::HashBase/; + +use Carp qw/croak cluck confess/; +use Test2::Util qw/get_tid CAN_THREAD CAN_FORK/; +use Scalar::Util qw/blessed weaken/; +use List::Util qw/first/; + +use Test2::API(); +use Test2::API::Context(); +use Test2::Util::Trace(); +use Test2::Util::Guard(); +use Time::HiRes(); + +use Test2::AsyncSubtest::Hub(); +use Test2::AsyncSubtest::Event::Attach(); +use Test2::AsyncSubtest::Event::Detach(); + +use Test2::Util::HashBase qw{ + name hub + trace frame send_to + events + finished + active + stack + id cid uuid + children + _in_use + _attached pid tid + start_stamp stop_stamp +}; + +sub CAN_REALLY_THREAD { + return 0 unless CAN_THREAD; + return 0 unless eval { require threads; threads->VERSION('1.34'); 1 }; + return 1; +} + + +my $UUID_VIA = Test2::API::_add_uuid_via_ref(); +my $CID = 1; +my @STACK; + +sub TOP { @STACK ? $STACK[-1] : undef } + +sub init { + my $self = shift; + + croak "'name' is a required attribute" + unless $self->{+NAME}; + + my $to = $self->{+SEND_TO} ||= Test2::API::test2_stack()->top; + + $self->{+STACK} = [@STACK]; + $_->{+_IN_USE}++ for reverse @STACK; + + $self->{+TID} = get_tid; + $self->{+PID} = $$; + $self->{+CID} = 'AsyncSubtest-' . $CID++; + $self->{+ID} = 1; + $self->{+FINISHED} = 0; + $self->{+ACTIVE} = 0; + $self->{+_IN_USE} = 0; + $self->{+CHILDREN} = []; + $self->{+UUID} = ${$UUID_VIA}->() if defined $$UUID_VIA; + + unless($self->{+HUB}) { + my $ipc = Test2::API::test2_ipc(); + my $formatter = Test2::API::test2_stack->top->format; + my $args = delete $self->{hub_init_args} || {}; + my $hub = Test2::AsyncSubtest::Hub->new( + %$args, + ipc => $ipc, + nested => $to->nested + 1, + buffered => 1, + formatter => $formatter, + ); + weaken($hub->{ast} = $self); + $self->{+HUB} = $hub; + } + + $self->{+TRACE} ||= Test2::Util::Trace->new( + frame => $self->{+FRAME} || [caller(1)], + buffered => $to->buffered, + nested => $to->nested, + cid => $self->{+CID}, + uuid => $self->{+UUID}, + hid => $to->hid, + huuid => $to->uuid, + ); + + my $hub = $self->{+HUB}; + $hub->set_ast_ids({}) unless $hub->ast_ids; + $hub->listen($self->_listener); +} + +sub _listener { + my $self = shift; + + my $events = $self->{+EVENTS} ||= []; + + sub { push @$events => $_[1] }; +} + +sub context { + my $self = shift; + + my $send_to = $self->{+SEND_TO}; + + confess "Attempt to close AsyncSubtest when original parent hub (a non async-subtest?) has ended" + if $send_to->ended; + + return Test2::API::Context->new( + trace => $self->{+TRACE}, + hub => $send_to, + ); +} + +sub _gen_event { + my $self = shift; + my ($type, $id, $hub) = @_; + + my $class = "Test2::AsyncSubtest::Event::$type"; + + return $class->new( + id => $id, + trace => Test2::Util::Trace->new( + frame => [caller(1)], + buffered => $hub->buffered, + nested => $hub->nested, + cid => $self->{+CID}, + uuid => $self->{+UUID}, + hid => $hub->hid, + huuid => $hub->uuid, + ), + ); +} + +sub cleave { + my $self = shift; + my $id = $self->{+ID}++; + $self->{+HUB}->ast_ids->{$id} = 0; + return $id; +} + +sub attach { + my $self = shift; + my ($id) = @_; + + croak "An ID is required" unless $id; + + croak "ID $id is not valid" + unless defined $self->{+HUB}->ast_ids->{$id}; + + croak "ID $id is already attached" + if $self->{+HUB}->ast_ids->{$id}; + + croak "You must attach INSIDE the child process/thread" + if $self->{+HUB}->is_local; + + $self->{+_ATTACHED} = [ $$, get_tid, $id ]; + $self->{+HUB}->send($self->_gen_event('Attach', $id, $self->{+HUB})); +} + +sub detach { + my $self = shift; + + if ($self->{+PID} == $$ && $self->{+TID} == get_tid) { + cluck "You must detach INSIDE the child process/thread ($$, " . get_tid . " instead of $self->{+PID}, $self->{+TID})"; + return; + } + + my $att = $self->{+_ATTACHED} + or croak "Not attached"; + + croak "Attempt to detach from wrong child" + unless $att->[0] == $$ && $att->[1] == get_tid; + + my $id = $att->[2]; + + $self->{+HUB}->send($self->_gen_event('Detach', $id, $self->{+HUB})); + + delete $self->{+_ATTACHED}; +} + +sub ready { return !shift->pending } +sub pending { + my $self = shift; + my $hub = $self->{+HUB}; + return -1 unless $hub->is_local; + + $hub->cull; + + return $self->{+_IN_USE} + keys %{$self->{+HUB}->ast_ids}; +} + +sub run { + my $self = shift; + my ($code, @args) = @_; + + croak "AsyncSubtest->run() takes a codeblock as the first argument" + unless $code && ref($code) eq 'CODE'; + + $self->start; + + my ($ok, $err, $finished); + T2_SUBTEST_WRAPPER: { + $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"/) { + $ok = undef; + $err = undef; + } + else { + $finished = 1; + } + } + + $self->stop; + + my $hub = $self->{+HUB}; + + if (!$finished) { + if(my $bailed = $hub->bailed_out) { + my $ctx = $self->context; + $ctx->bail($bailed->reason); + return; + } + my $code = $hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } + + unless ($ok) { + my $e = Test2::Event::Exception->new( + error => $err, + trace => Test2::Util::Trace->new( + frame => [caller(0)], + buffered => $hub->buffered, + nested => $hub->nested, + cid => $self->{+CID}, + uuid => $self->{+UUID}, + hid => $hub->hid, + huuid => $hub->uuid, + ), + ); + $hub->send($e); + } + + return $hub->is_passing; +} + +sub start { + my $self = shift; + + croak "Subtest is already complete" + if $self->{+FINISHED}; + + $self->{+START_STAMP} = Time::HiRes::time() unless defined $self->{+START_STAMP}; + + $self->{+ACTIVE}++; + + push @STACK => $self; + my $hub = $self->{+HUB}; + my $stack = Test2::API::test2_stack(); + $stack->push($hub); + + return $hub->is_passing; +} + +sub stop { + my $self = shift; + + croak "Subtest is not active" + unless $self->{+ACTIVE}--; + + croak "AsyncSubtest stack mismatch" + unless @STACK && $self == $STACK[-1]; + + $self->{+STOP_STAMP} = Time::HiRes::time(); + + pop @STACK; + + my $hub = $self->{+HUB}; + my $stack = Test2::API::test2_stack(); + $stack->pop($hub); + return $hub->is_passing; +} + +sub finish { + my $self = shift; + my %params = @_; + + my $hub = $self->hub; + + croak "Subtest is already finished" + if $self->{+FINISHED}++; + + croak "Subtest can only be finished in the process/thread that created it" + unless $hub->is_local; + + croak "Subtest is still active" + if $self->{+ACTIVE}; + + $self->wait; + $self->{+STOP_STAMP} = Time::HiRes::time() unless defined $self->{+STOP_STAMP}; + my $stop_stamp = $self->{+STOP_STAMP}; + + my $todo = $params{todo}; + my $skip = $params{skip}; + my $empty = !@{$self->{+EVENTS}}; + my $no_asserts = !$hub->count; + my $collapse = $params{collapse}; + my $no_plan = $params{no_plan} || ($collapse && $no_asserts) || $skip; + + my $trace = Test2::Util::Trace->new( + frame => $self->{+TRACE}->{frame}, + buffered => $hub->buffered, + nested => $hub->nested, + cid => $self->{+CID}, + uuid => $self->{+UUID}, + hid => $hub->hid, + huuid => $hub->uuid, + ); + + $hub->finalize($trace, !$no_plan) + unless $hub->no_ending || $hub->ended; + + if ($hub->ipc) { + $hub->ipc->drop_hub($hub->hid); + $hub->set_ipc(undef); + } + + return $hub->is_passing if $params{silent}; + + my $ctx = $self->context; + + my $pass = 1; + if ($skip) { + $ctx->skip($self->{+NAME}, $skip); + } + else { + if ($collapse && $empty) { + $ctx->ok($hub->is_passing, $self->{+NAME}); + return $hub->is_passing; + } + + if ($collapse && $no_asserts) { + push @{$self->{+EVENTS}} => Test2::Event::Plan->new(trace => $trace, max => 0, directive => 'SKIP', reason => "No assertions"); + } + + my $e = $ctx->build_event( + 'Subtest', + pass => $hub->is_passing, + subtest_id => $hub->id, + subtest_uuid => $hub->uuid, + name => $self->{+NAME}, + buffered => 1, + subevents => $self->{+EVENTS}, + start_stamp => $self->{+START_STAMP}, + stop_stamp => $self->{+STOP_STAMP}, + $todo ? ( + todo => $todo, + effective_pass => 1, + ) : (), + ); + + $ctx->hub->send($e); + + unless ($e->effective_pass) { + $ctx->failure_diag($e); + + $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) + if $hub->plan && !$hub->check_plan && !grep {$_->causes_fail} @{$self->{+EVENTS}}; + } + + $pass = $e->pass; + } + + $_->{+_IN_USE}-- for reverse @{$self->{+STACK}}; + + return $pass; +} + +sub wait { + my $self = shift; + + my $hub = $self->{+HUB}; + my $children = $self->{+CHILDREN}; + + while (@$children) { + $hub->cull; + if (my $child = pop @$children) { + if (blessed($child)) { + $child->join; + } + else { + waitpid($child, 0); + } + } + else { + Time::HiRes::sleep('0.01'); + } + } + + $hub->cull; + + cluck "Subtest '$self->{+NAME}': All children have completed, but we still appear to be pending" + if $hub->is_local && keys %{$self->{+HUB}->ast_ids}; +} + +sub fork { + croak "Forking is not supported" unless CAN_FORK; + my $self = shift; + my $id = $self->cleave; + my $pid = CORE::fork(); + + unless (defined $pid) { + delete $self->{+HUB}->ast_ids->{$id}; + croak "Failed to fork"; + } + + if($pid) { + push @{$self->{+CHILDREN}} => $pid; + return $pid; + } + + $self->attach($id); + + return $self->_guard; +} + +sub run_fork { + my $self = shift; + my ($code, @args) = @_; + + my $f = $self->fork; + return $f unless blessed($f); + + $self->run($code, @args); + + $self->detach(); + $f->dismiss(); + exit 0; +} + +sub run_thread { + croak "Threading is not supported" + unless CAN_REALLY_THREAD; + + my $self = shift; + my ($code, @args) = @_; + + my $id = $self->cleave; + my $thr = threads->create(sub { + $self->attach($id); + + $self->run($code, @args); + + $self->detach(get_tid); + return 0; + }); + + push @{$self->{+CHILDREN}} => $thr; + + return $thr; +} + +sub _guard { + my $self = shift; + + my ($pid, $tid) = ($$, get_tid); + + return Test2::Util::Guard->new(sub { + return unless $$ == $pid && get_tid == $tid; + + my $error = "Scope Leak"; + if (my $ex = $@) { + chomp($ex); + $error .= " ($ex)"; + } + + cluck $error; + + my $e = $self->context->build_event( + 'Exception', + error => "$error\n", + ); + $self->{+HUB}->send($e); + $self->detach(); + exit 255; + }); +} + +sub DESTROY { + my $self = shift; + return unless $self->{+NAME}; + + if (my $att = $self->{+_ATTACHED}) { + return unless $self->{+HUB}; + eval { $self->detach() }; + } + + return if $self->{+FINISHED}; + return unless $self->{+PID} == $$; + return unless $self->{+TID} == get_tid; + + local $@; + eval { $_->{+_IN_USE}-- for reverse @{$self->{+STACK}} }; + + warn "Subtest $self->{+NAME} did not finish!"; + exit 255; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::AsyncSubtest - Object representing an async subtest. + +=head1 DESCRIPTION + +Regular subtests have a limited scope, they start, events are generated, then +they close and send an L event. This is a problem if you +want the subtest to keep receiving events while other events are also being +generated. This class implements subtests that stay open until you decide to +close them. + +This is mainly useful for tools that start a subtest in one process and then +spawn children. In many cases it is nice to let the parent process continue +instead of waiting on the children. + +=head1 SYNOPSIS + + use Test2::AsyncSubtest; + + my $ast = Test2::AsyncSubtest->new(name => foo); + + $ast->run(sub { + ok(1, "Event in parent" ); + }); + + ok(1, "Event outside of subtest"); + + $ast->run_fork(sub { + ok(1, "Event in child process"); + }); + + ... + + $ast->finish; + + done_testing; + +=head1 CONSTRUCTION + + my $ast = Test2::AsyncSubtest->new( ... ); + +=over 4 + +=item name => $name (required) + +Name of the subtest. This construction argument is required. + +=item send_to => $hub (optional) + +Hub to which the final subtest event should be sent. This must be an instance +of L or a subclass. If none is specified then the current top hub +will be used. + +=item trace => $trace (optional) + +File/Line to which errors should be attributed. This must be an instance of +L. If none is specified then the file/line where the +constructor was called will be used. + +=item hub => $hub (optional) + +Use this to specify a hub the subtest should use. By default a new hub is +generated. This must be an instance of L. + +=back + +=head1 METHODS + +=head2 SIMPLE ACCESSORS + +=over 4 + +=item $bool = $ast->active + +True if the subtest is active. The subtest is active if its hub appears in the +global hub stack. This is true when C<< $ast->run(...) >> us running. + +=item $arrayref = $ast->children + +Get an arrayref of child processes/threads. Numerical items are PIDs, blessed +items are L instances. + +=item $arrayref = $ast->events + +Get an arrayref of events that have been sent to the subtests hub. + +=item $bool = $ast->finished + +True if C has already been called. + +=item $hub = $ast->hub + +The hub created for the subtest. + +=item $int = $ast->id + +Attach/Detach counter. Used internally, not useful to users. + +=item $str = $ast->name + +Name of the subtest. + +=item $pid = $ast->pid + +PID in which the subtest was created. + +=item $tid = $ast->tid + +Thread ID in which the subtest was created. + +=item $hub = $ast->send_to + +Hub to which the final subtest event should be sent. + +=item $arrayref = $ast->stack + +Stack of async subtests at the time this one was created. This is mainly for +internal use. + +=item $trace = $ast->trace + +L instance used for error reporting. + +=back + +=head2 INTERFACE + +=over 4 + +=item $ast->attach($id) + +Attach a subtest in a child/process to the original. + +B C<< my $id = $ast->cleave >> must have been called in the parent +process/thread before the child was started, the id it returns must be used in +the call to C<< $ast->attach($id) >> + +=item $id = $ast->cleave + +Prepare a slot for a child process/thread to attach. This must be called BEFORE +the child process or thread is started. The ID returned is used by C. + +This must only be called in the original process/thread. + +=item $ctx = $ast->context + +Get an L instance that can be used to send events to the +context in which the hub was created. This is not a canonical context, you +should not call C<< $ctx->release >> on it. + +=item $ast->detach + +Detach from the parent in a child process/thread. This should be called just +before the child exits. + +=item $ast->finish + +=item $ast->finish(%options) + +Finish the subtest, wait on children, and send the final subtest event. + +This must only be called in the original process/thread. + +B This calls C<< $ast->wait >>. + +These are the options: + +=over 4 + +=item collapse => 1 + +This intelligently allows a subtest to be empty. + +If no events bump the test count then the subtest no final plan will be added. +The subtest will not be considered a failure (normally an empty subtest is a +failure). + +If there are no events at all the subtest will be collapsed into an +L event. + +=item silent => 1 + +This will prevent finish from generating a final L +event. This effectively ends the subtest without it effecting the parent +subtest (or top level test). + +=item no_plan => 1 + +This will prevent a final plan from being added to the subtest for you when +none is directly specified. + +=item skip => "reason" + +This will issue an L instead of a subtest. This will throw +an exception if any events have been seen, or if state implies events have +occurred. + +=back + +=item $out = $ast->fork + +This is a slightly higher level interface to fork. Running it will fork your +code in-place just like C. It will return a pid in the parent, and an +L instance in the child. An exception will be thrown if +fork fails. + +It is recommended that you use C<< $ast->run_fork(sub { ... }) >> instead. + +=item $bool = $ast->pending + +True if there are child processes, threads, or subtests that depend on this +one. + +=item $bool = $ast->ready + +This is essentially C<< !$ast->pending >>. + +=item $ast->run(sub { ... }) + +Run the provided codeblock inside the subtest. This will push the subtest hub +onto the stack, run the code, then pop the hub off the stack. + +=item $pid = $ast->run_fork(sub { ... }) + +Same as C<< $ast->run() >>, except that the codeblock is run in a child +process. + +You do not need to directly call C, that will be done for you when +C<< $ast->wait >>, or C<< $ast->finish >> are called. + +=item my $thr = $ast->run_thread(sub { ... }); + +B<** DISCOURAGED **> Threads cause problems. This method remains for anyone who +REALLY wants it, but it is no longer supported. Tests for this functionality do +not even run unless the AUTHOR_TESTING or T2_DO_THREAD_TESTS env vars are +enabled. + +Same as C<< $ast->run() >>, except that the codeblock is run in a child +thread. + +You do not need to directly call C<< $thr->join >>, that is done for you when +C<< $ast->wait >>, or C<< $ast->finish >> are called. + +=item $passing = $ast->start + +Push the subtest hub onto the stack. Returns the current pass/fail status of +the subtest. + +=item $ast->stop + +Pop the subtest hub off the stack. Returns the current pass/fail status of the +subtest. + +=item $ast->wait + +Wait on all threads/processes that were started using C<< $ast->fork >>, +C<< $ast->run_fork >>, or C<< $ast->run_thread >>. + +=back + +=head1 SOURCE + +The source code repository for Test2-AsyncSubtest 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Attach.pm b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Attach.pm new file mode 100644 index 000000000000..640f6b96c8d9 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Attach.pm @@ -0,0 +1,90 @@ +package Test2::AsyncSubtest::Event::Attach; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use base 'Test2::Event'; +use Test2::Util::HashBase qw/id/; + +sub no_display { 1 } + +sub callback { + my $self = shift; + my ($hub) = @_; + + my $id = $self->{+ID}; + my $ids = $hub->ast_ids; + + unless (defined $ids->{$id}) { + require Test2::Event::Exception; + my $trace = $self->trace; + $hub->send( + Test2::Event::Exception->new( + trace => $trace, + error => "Invalid AsyncSubtest attach ID: $id at " . $trace->debug . "\n", + ) + ); + return; + } + + if ($ids->{$id}++) { + require Test2::Event::Exception; + my $trace = $self->trace; + $hub->send( + Test2::Event::Exception->new( + trace => $trace, + error => "AsyncSubtest ID $id already attached at " . $trace->debug . "\n", + ) + ); + return; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::AsyncSubtest::Event::Attach - Event to attach a subtest to the parent. + +=head1 DESCRIPTION + +Used internally by L. No user serviceable parts inside. + +=head1 SOURCE + +The source code repository for Test2-AsyncSubtest 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Detach.pm b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Detach.pm new file mode 100644 index 000000000000..ab2aab2373b8 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Event/Detach.pm @@ -0,0 +1,90 @@ +package Test2::AsyncSubtest::Event::Detach; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use base 'Test2::Event'; +use Test2::Util::HashBase qw/id/; + +sub no_display { 1 } + +sub callback { + my $self = shift; + my ($hub) = @_; + + my $id = $self->{+ID}; + my $ids = $hub->ast_ids; + + unless (defined $ids->{$id}) { + require Test2::Event::Exception; + my $trace = $self->trace; + $hub->send( + Test2::Event::Exception->new( + trace => $trace, + error => "Invalid AsyncSubtest detach ID: $id at " . $trace->debug . "\n", + ) + ); + return; + } + + unless (delete $ids->{$id}) { + require Test2::Event::Exception; + my $trace = $self->trace; + $hub->send( + Test2::Event::Exception->new( + trace => $trace, + error => "AsyncSubtest ID $id is not attached at " . $trace->debug . "\n", + ) + ); + return; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::AsyncSubtest::Event::Detach - Event to detach a subtest from the parent. + +=head1 DESCRIPTION + +Used internally by L. No user serviceable parts inside. + +=head1 SOURCE + +The source code repository for Test2-AsyncSubtest 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Formatter.pm b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Formatter.pm new file mode 100644 index 000000000000..99ecb04b04dd --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Formatter.pm @@ -0,0 +1,9 @@ +package Test2::AsyncSubtest::Formatter; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +die "Should not load this anymore"; + +1; diff --git a/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Hub.pm b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Hub.pm new file mode 100644 index 000000000000..0df20c4e14f6 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/AsyncSubtest/Hub.pm @@ -0,0 +1,98 @@ +package Test2::AsyncSubtest::Hub; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use base 'Test2::Hub::Subtest'; +use Test2::Util::HashBase qw/ast_ids ast/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + if (my $format = $self->format) { + my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1; + $self->format(undef) if $hide; + } +} + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + 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; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::AsyncSubtest::Hub - Hub used by async subtests. + +=head1 DESCRIPTION + +This is a subclass of L used for async subtests. + +=head1 SYNOPSIS + +You should not use this directly. + +=head1 METHODS + +=over 4 + +=item $ast = $hub->ast + +Get the L object to which this hub is bound. + +=back + +=head1 SOURCE + +The source code repository for Test2-AsyncSubtest 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/Bundle.pm b/cpan/Test2-Suite/lib/Test2/Bundle.pm new file mode 100644 index 000000000000..237a525e791b --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Bundle.pm @@ -0,0 +1,87 @@ +package Test2::Bundle; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Bundle - Documentation for bundles. + +=head1 DESCRIPTION + +Bundles are collections of Tools and Plugins. Bundles should not provide any +tools or behaviors of their own, they should simply combine the tools and +behaviors of other packages. + +=head1 FAQ + +=over 4 + +=item Should my bundle subclass Test2::Bundle? + +No. Currently this class is empty. Eventually we may want to add behavior, in +which case we do not want anyone to already be subclassing it. + +=back + +=head1 HOW DO I WRITE A BUNDLE? + +Writing a bundle can be very simple: + + package Test2::Bundle::MyBundle; + use strict; + use warnings; + + use Test2::Plugin::ExitSummary; # Load a plugin + + use Test2::Tools::Basic qw/ok plan done_testing/; + + # Re-export the tools + our @EXPORTS = qw/ok plan done_testing/; + use base 'Exporter'; + + 1; + +If you want to do anything more complex you should look into L +and L. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Bundle/Extended.pm b/cpan/Test2-Suite/lib/Test2/Bundle/Extended.pm new file mode 100644 index 000000000000..9117f0175be4 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Bundle/Extended.pm @@ -0,0 +1,487 @@ +package Test2::Bundle::Extended; +use strict; +use warnings; + +use Test2::V0; + +our $VERSION = '0.000156'; + +BEGIN { + push @Test2::Bundle::Extended::ISA => 'Test2::V0'; + no warnings 'once'; + *EXPORT = \@Test2::V0::EXPORT; +} + +our %EXPORT_TAGS = ( + 'v1' => \@Test2::Bundle::Extended::EXPORT, +); + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Bundle::Extended - Old name for Test2::V0 + +=head1 *** DEPRECATED *** + +This bundle has been renamed to L, in which the C<':v1'> tag has +been removed as unnecessary. + +=head1 DESCRIPTION + +This is the big-daddy bundle. This bundle includes nearly every tool, and +several plugins, that the Test2 author uses. This bundle is used +extensively to test L itself. + +=head1 SYNOPSIS + + use Test2::Bundle::Extended ':v1'; + + ok(1, "pass"); + + ... + + done_testing; + +=head1 RESOLVING CONFLICTS WITH MOOSE + + use Test2::Bundle::Extended '!meta'; + +L and L both export very different C +subs. Adding C<'!meta'> to the import args will prevent the sub from being +imported. This bundle also exports the sub under the name C so +you can use that spelling as an alternative. + +=head2 TAGS + +=over 4 + +=item :v1 + +=item :DEFAULT + +The following are all identical: + + use Test2::Bundle::Extended; + + use Test2::Bundle::Extended ':v1'; + + use Test2::Bundle::Extended ':DEFAULT'; + +=back + +=head2 RENAMING ON IMPORT + + use Test2::Bundle::Extended ':v1', '!ok', ok => {-as => 'my_ok'}; + +This bundle uses L for exporting, as such you can use any arguments +it accepts. + +Explanation: + +=over 4 + +=item ':v1' + +Use the default tag, all default exports. + +=item '!ok' + +Do not export C + +=item ok => {-as => 'my_ok'} + +Actually, go ahead and import C but under the name C. + +=back + +If you did not add the C<'!ok'> argument then you would have both C and +C + +=head1 PRAGMAS + +All of these can be disabled via individual import arguments, or by the +C<-no_pragmas> argument. + + use Test2::Bundle::Extended -no_pragmas => 1; + +=head2 STRICT + +L is turned on for you. You can disable this with the C<-no_strict> or +C<-no_pragmas> import arguments: + + use Test2::Bundle::Extended -no_strict => 1; + +=head2 WARNINGS + +L are turned on for you. You can disable this with the +C<-no_warnings> or C<-no_pragmas> import arguments: + + use Test2::Bundle::Extended -no_warnings => 1; + +=head2 UTF8 + +This is actually done via the L plugin, see the +L section for details. + +B C<< -no_pragmas => 1 >> will turn off the entire plugin. + +=head1 PLUGINS + +=head2 SRAND + +See L. + +This will set the random seed to today's date. You can provide an alternate seed +with the C<-srand> import option: + + use Test2::Bundle::Extended -srand => 1234; + +=head2 UTF8 + +See L. + +This will set the file, and all output handles (including formatter handles), to +utf8. This will turn on the utf8 pragma for the current scope. + +This can be disabled using the C<< -no_utf8 => 1 >> or C<< -no_pragmas => 1 >> +import arguments. + + use Test2::Bundle::Extended -no_utf8 => 1; + +=head2 EXIT SUMMARY + +See L. + +This plugin has no configuration. + +=head1 API FUNCTIONS + +See L for these + +=over 4 + +=item $ctx = context() + +=item $events = intercept { ... } + +=back + +=head1 TOOLS + +=head2 TARGET + +See L. + +You can specify a target class with the C<-target> import argument. If you do +not provide a target then C<$CLASS> and C will not be imported. + + use Test2::Bundle::Extended -target => 'My::Class'; + + print $CLASS; # My::Class + print CLASS(); # My::Class + +Or you can specify names: + + use Test2::Bundle::Extended -target => { pkg => 'Some::Package' }; + + pkg()->xxx; # Call 'xxx' on Some::Package + $pkg->xxx; # Same + +=over 4 + +=item $CLASS + +Package variable that contains the target class name. + +=item $class = CLASS() + +Constant function that returns the target class name. + +=back + +=head2 DEFER + +See L. + +=over 4 + +=item def $func => @args; + +=item do_def() + +=back + +=head2 BASIC + +See L. + +=over 4 + +=item ok($bool, $name) + +=item pass($name) + +=item fail($name) + +=item diag($message) + +=item note($message) + +=item $todo = todo($reason) + +=item todo $reason => sub { ... } + +=item skip($reason, $count) + +=item plan($count) + +=item skip_all($reason) + +=item done_testing() + +=item bail_out($reason) + +=back + +=head2 COMPARE + +See L. + +=over 4 + +=item is($got, $want, $name) + +=item isnt($got, $do_not_want, $name) + +=item like($got, qr/match/, $name) + +=item unlike($got, qr/mismatch/, $name) + +=item $check = match(qr/pattern/) + +=item $check = mismatch(qr/pattern/) + +=item $check = validator(sub { return $bool }) + +=item $check = hash { ... } + +=item $check = array { ... } + +=item $check = bag { ... } + +=item $check = object { ... } + +=item $check = meta { ... } + +=item $check = number($num) + +=item $check = string($str) + +=item $check = check_isa($class_name) + +=item $check = in_set(@things) + +=item $check = not_in_set(@things) + +=item $check = check_set(@things) + +=item $check = item($thing) + +=item $check = item($idx => $thing) + +=item $check = field($name => $val) + +=item $check = call($method => $expect) + +=item $check = call_list($method => $expect) + +=item $check = call_hash($method => $expect) + +=item $check = prop($name => $expect) + +=item $check = check($thing) + +=item $check = T() + +=item $check = F() + +=item $check = D() + +=item $check = DF() + +=item $check = E() + +=item $check = DNE() + +=item $check = FDNE() + +=item $check = U() + +=item $check = L() + +=item $check = exact_ref($ref) + +=item end() + +=item etc() + +=item filter_items { grep { ... } @_ } + +=item $check = event $type => ... + +=item @checks = fail_events $type => ... + +=back + +=head2 CLASSIC COMPARE + +See L. + +=over 4 + +=item cmp_ok($got, $op, $want, $name) + +=back + +=head2 SUBTEST + +See L. + +=over 4 + +=item subtest $name => sub { ... } + +(Note: This is called C in the Tools module.) + +=back + +=head2 CLASS + +See L. + +=over 4 + +=item can_ok($thing, @methods) + +=item isa_ok($thing, @classes) + +=item DOES_ok($thing, @roles) + +=back + +=head2 ENCODING + +See L. + +=over 4 + +=item set_encoding($encoding) + +=back + +=head2 EXPORTS + +See L. + +=over 4 + +=item imported_ok('function', '$scalar', ...) + +=item not_imported_ok('function', '$scalar', ...) + +=back + +=head2 REF + +See L. + +=over 4 + +=item ref_ok($ref, $type) + +=item ref_is($got, $want) + +=item ref_is_not($got, $do_not_want) + +=back + +=head2 MOCK + +See L. + +=over 4 + +=item $control = mock ... + +=item $bool = mocked($thing) + +=back + +=head2 EXCEPTION + +See L. + +=over 4 + +=item $exception = dies { ... } + +=item $bool = lives { ... } + +=item $bool = try_ok { ... } + +=back + +=head2 WARNINGS + +See L. + +=over 4 + +=item $count = warns { ... } + +=item $warning = warning { ... } + +=item $warnings_ref = warnings { ... } + +=item $bool = no_warnings { ... } + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Bundle/More.pm b/cpan/Test2-Suite/lib/Test2/Bundle/More.pm new file mode 100644 index 000000000000..3ef6eb7c026a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Bundle/More.pm @@ -0,0 +1,241 @@ +package Test2::Bundle::More; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Plugin::ExitSummary; + +use Test2::Tools::Basic qw{ + ok pass fail skip todo diag note + plan skip_all done_testing bail_out +}; + +use Test2::Tools::ClassicCompare qw{ + is is_deeply isnt like unlike cmp_ok +}; + +use Test2::Tools::Class qw/can_ok isa_ok/; +use Test2::Tools::Subtest qw/subtest_streamed/; + +BEGIN { + *BAIL_OUT = \&bail_out; + *subtest = \&subtest_streamed; +} + +our @EXPORT = qw{ + ok pass fail skip todo diag note + plan skip_all done_testing BAIL_OUT + + is isnt like unlike is_deeply cmp_ok + + isa_ok can_ok + + subtest +}; +use base 'Exporter'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Bundle::More - ALMOST a drop-in replacement for Test::More. + +=head1 DESCRIPTION + +This bundle is intended to be a (mostly) drop-in replacement for +L. See L<"KEY DIFFERENCES FROM Test::More"> for details. + +=head1 SYNOPSIS + + use Test2::Bundle::More; + + ok(1, "pass"); + + ... + + done_testing; + +=head1 PLUGINS + +This loads L. + +=head1 TOOLS + +These are from L. See L for details. + +=over 4 + +=item ok($bool, $name) + +=item pass($name) + +=item fail($name) + +=item skip($why, $count) + +=item $todo = todo($why) + +=item diag($message) + +=item note($message) + +=item plan($count) + +=item skip_all($why) + +=item done_testing() + +=item BAIL_OUT($why) + +=back + +These are from L. See +L for details. + +=over 4 + +=item is($got, $want, $name) + +=item isnt($got, $donotwant, $name) + +=item like($got, qr/match/, $name) + +=item unlike($got, qr/mismatch/, $name) + +=item is_deeply($got, $want, "Deep compare") + +=item cmp_ok($got, $op, $want, $name) + +=back + +These are from L. See L for details. + +=over 4 + +=item isa_ok($thing, @classes) + +=item can_ok($thing, @subs) + +=back + +This is from L. It is called C in +that package. + +=over 4 + +=item subtest $name => sub { ... } + +=back + +=head1 KEY DIFFERENCES FROM Test::More + +=over 4 + +=item You cannot plan at import. + +THIS WILL B WORK: + + use Test2::Bundle::More tests => 5; + +Instead you must plan in a separate statement: + + use Test2::Bundle::More; + plan 5; + +=item You have three subs imported for use in planning + +Use C, C, or C for your +planning. + +=item isa_ok accepts different arguments + +C in Test::More was: + + isa_ok($thing, $isa, $alt_thing_name); + +This was very inconsistent with tools like C. + +In Test2::Bundle::More, C takes a C<$thing> and a list of C<@isa>. + + isa_ok($thing, $class1, $class2, ...); + +=back + +=head2 THESE FUNCTIONS AND VARIABLES HAVE BEEN REMOVED + +=over 4 + +=item $TODO + +See C. + +=item use_ok() + +=item require_ok() + +These are not necessary. Use C and C directly. If there is an +error loading the module the test will catch the error and fail. + +=item todo_skip() + +Not necessary. + +=item eq_array() + +=item eq_hash() + +=item eq_set() + +Discouraged in Test::More. + +=item explain() + +This started a fight between Test developers, who may now each write their own +implementations in L. (See explain in L vs L. +Hint: Test::Most wrote it first, then Test::More added it, but broke +compatibility). + +=item new_ok() + +Not necessary. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Bundle/Simple.pm b/cpan/Test2-Suite/lib/Test2/Bundle/Simple.pm new file mode 100644 index 000000000000..e9969af64573 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Bundle/Simple.pm @@ -0,0 +1,120 @@ +package Test2::Bundle::Simple; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Plugin::ExitSummary; + +use Test2::Tools::Basic qw/ok plan done_testing skip_all/; + +our @EXPORT = qw/ok plan done_testing skip_all/; +use base 'Exporter'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Bundle::Simple - ALMOST a drop-in replacement for Test::Simple. + +=head1 DESCRIPTION + +This bundle is intended to be a (mostly) drop-in replacement for +L. See L<"KEY DIFFERENCES FROM Test::Simple"> for details. + +=head1 SYNOPSIS + + use Test2::Bundle::Simple; + + ok(1, "pass"); + + done_testing; + +=head1 PLUGINS + +This loads L. + +=head1 TOOLS + +These are all from L. + +=over 4 + +=item ok($bool, $name) + +Run a test. If bool is true, the test passes. If bool is false, it fails. + +=item plan($count) + +Tell the system how many tests to expect. + +=item skip_all($reason) + +Tell the system to skip all the tests (this will exit the script). + +=item done_testing(); + +Tell the system that all tests are complete. You can use this instead of +setting a plan. + +=back + +=head1 KEY DIFFERENCES FROM Test::Simple + +=over 4 + +=item You cannot plan at import. + +THIS WILL B WORK: + + use Test2::Bundle::Simple tests => 5; + +Instead you must plan in a separate statement: + + use Test2::Bundle::Simple; + plan 5; + +=item You have three subs imported for use in planning + +Use C, C, or C for your +planning. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare.pm b/cpan/Test2-Suite/lib/Test2/Compare.pm new file mode 100644 index 000000000000..82c1eaf7e242 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare.pm @@ -0,0 +1,449 @@ +package Test2::Compare; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Scalar::Util qw/blessed/; +use Test2::Util qw/try/; +use Test2::Util::Ref qw/rtype/; + +use Carp qw/croak/; + +our @EXPORT_OK = qw{ + compare + get_build push_build pop_build build + strict_convert relaxed_convert convert +}; +use base 'Exporter'; + +sub compare { + my ($got, $check, $convert) = @_; + + $check = $convert->($check); + + return $check->run( + id => undef, + got => $got, + exists => 1, + convert => $convert, + seen => {}, + ); +} + +my @BUILD; + +sub get_build { @BUILD ? $BUILD[-1] : undef } +sub push_build { push @BUILD => $_[0] } + +sub pop_build { + return pop @BUILD if @BUILD && $_[0] && $BUILD[-1] == $_[0]; + my $have = @BUILD ? "$BUILD[-1]" : 'undef'; + my $want = $_[0] ? "$_[0]" : 'undef'; + croak "INTERNAL ERROR: Attempted to pop incorrect build, have $have, tried to pop $want"; +} + +sub build { + my ($class, $code) = @_; + + my @caller = caller(1); + + die "'$caller[3]\()' should not be called in void context in $caller[1] line $caller[2]\n" + unless defined(wantarray); + + my $build = $class->new(builder => $code, called => \@caller); + + push @BUILD => $build; + my ($ok, $err) = try { $code->($build); 1 }; + pop @BUILD; + die $err unless $ok; + + return $build; +} + +sub strict_convert { convert($_[0], { implicit_end => 1, use_regex => 0, use_code => 0 }) } +sub relaxed_convert { convert($_[0], { implicit_end => 0, use_regex => 1, use_code => 1 }) } + +my $CONVERT_LOADED = 0; +my %ALLOWED_KEYS = ( implicit_end => 1, use_regex => 1, use_code => 1 ); +sub convert { + my ($thing, $config) = @_; + + unless($CONVERT_LOADED) { + require Test2::Compare::Array; + require Test2::Compare::Base; + require Test2::Compare::Custom; + require Test2::Compare::DeepRef; + require Test2::Compare::Hash; + require Test2::Compare::Pattern; + require Test2::Compare::Ref; + require Test2::Compare::Regex; + require Test2::Compare::Scalar; + require Test2::Compare::String; + require Test2::Compare::Undef; + require Test2::Compare::Wildcard; + $CONVERT_LOADED = 1; + } + + if (ref($config)) { + my $bad = join ', ' => grep { !$ALLOWED_KEYS{$_} } keys %$config; + croak "The following config options are not understood by convert(): $bad" if $bad; + $config->{implicit_end} = 1 unless defined $config->{implicit_end}; + $config->{use_regex} = 1 unless defined $config->{use_regex}; + $config->{use_code} = 0 unless defined $config->{use_code}; + } + else { # Legacy... + if ($config) { + $config = { + implicit_end => 1, + use_regex => 0, + use_code => 0, + }; + } + else { + $config = { + implicit_end => 0, + use_regex => 1, + use_code => 1, + }; + } + } + + return _convert($thing, $config); +} + +sub _convert { + my ($thing, $config) = @_; + + return Test2::Compare::Undef->new() + unless defined $thing; + + if (blessed($thing) && $thing->isa('Test2::Compare::Base')) { + if ($config->{implicit_end} && $thing->can('set_ending') && !defined $thing->ending) { + my $clone = $thing->clone; + $clone->set_ending('implicit'); + return $clone; + } + + return $thing unless $thing->isa('Test2::Compare::Wildcard'); + my $newthing = _convert($thing->expect, $config); + $newthing->set_builder($thing->builder) unless $newthing->builder; + $newthing->set_file($thing->_file) unless $newthing->_file; + $newthing->set_lines($thing->_lines) unless $newthing->_lines; + return $newthing; + } + + my $type = rtype($thing); + + return Test2::Compare::Array->new(inref => $thing, $config->{implicit_end} ? (ending => 1) : ()) + if $type eq 'ARRAY'; + + return Test2::Compare::Hash->new(inref => $thing, $config->{implicit_end} ? (ending => 1) : ()) + if $type eq 'HASH'; + + return Test2::Compare::Pattern->new( + pattern => $thing, + stringify_got => 1, + ) if $config->{use_regex} && $type eq 'REGEXP'; + + return Test2::Compare::Custom->new(code => $thing) + if $config->{use_code} && $type eq 'CODE'; + + return Test2::Compare::Regex->new(input => $thing) + if $type eq 'REGEXP'; + + if ($type eq 'SCALAR' || $type eq 'VSTRING') { + my $nested = _convert($$thing, $config); + return Test2::Compare::Scalar->new(item => $nested); + } + + return Test2::Compare::DeepRef->new(input => $thing) + if $type eq 'REF'; + + return Test2::Compare::Ref->new(input => $thing) + if $type; + + # is() will assume string and use 'eq' + return Test2::Compare::String->new(input => $thing); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare - Test2 extension for writing deep comparison tools. + +=head1 DESCRIPTION + +This library is the driving force behind deep comparison tools such as +C and +C. + +=head1 SYNOPSIS + + package Test2::Tools::MyCheck; + + use Test2::Compare::MyCheck; + use Test2::Compare qw/compare/; + + sub MyCheck { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my $delta = compare($got, $exp, \&convert); + + if ($delta) { + $ctx->fail($name, $delta->diag, @diag); + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; + } + + sub convert { + my $thing = shift; + return $thing if blessed($thing) && $thing->isa('Test2::Compare::MyCheck'); + + return Test2::Compare::MyCheck->new(stuff => $thing); + } + +See L for details about writing a custom check. + +=head1 EXPORTS + +=over 4 + +=item $delta = compare($got, $expect, \&convert) + +This will compare the structures in C<$got> with those in C<$expect>, The +convert sub should convert vanilla structures inside C<$expect> into checks. +If there are differences in the structures they will be reported back as an +L tree. + +=item $build = get_build() + +Get the current global build, if any. + +=item push_build($build) + +Set the current global build. + +=item $build = pop_build($build) + +Unset the current global build. This will throw an exception if the build +passed in is different from the current global. + +=item build($class, sub { ... }) + +Run the provided codeblock with a new instance of C<$class> as the current +build. Returns the new build. + +=item $check = convert($thing) + +=item $check = convert($thing, $config) + +This convert function is used by C and C +under the hood. It can also be used as the basis for other convert functions. + +If you want to use it with a custom configuration you should wrap it in another +sub like so: + + sub my_convert { + my $thing_to_convert = shift; + return convert( + $thing_to_convert, + { ... } + ); + } + +Or the short variant: + + sub my_convert { convert($_[0], { ... }) } + +There are several configuration options, here they are with the default setting +listed first: + +=over 4 + +=item implicit_end => 1 + +This option toggles array/hash boundaries. If this is true then no extra hash +keys or array indexes will be allowed. This setting effects generated compare +objects as well as any passed in. + +=item use_regex => 1 + +This option toggles regex matching. When true (default) regexes are converted +to checks such that values must match the regex. When false regexes will be +compared to see if they are identical regexes. + +=item use_code => 0 + +This option toggles code matching. When false (default) coderefs in structures +must be the same coderef as specified. When true coderefs will be run to verify +the value being checked. + +=back + +=item $check = strict_convert($thing) + +Convert C<$thing> to an L object. This will behave strictly +which means it uses these settings: + +=over 4 + +=item implicit_end => 1 + +Array bounds will be checked when this object is used in a comparison. No +unexpected hash keys can be present. + +=item use_code => 0 + +Sub references will be compared as refs (IE are these sub refs the same ref?) + +=item use_regex => 0 + +Regexes will be compared directly (IE are the regexes the same?) + +=back + +=item $compare = relaxed_convert($thing) + +Convert C<$thing> to an L object. This will be relaxed which +means it uses these settings: + +=over 4 + +=item implicit_end => 0 + +Array bounds will not be checked when this object is used in a comparison. +Unexpected hash keys can be present. + +=item use_code => 1 + +Sub references will be run to verify a value. + +=item use_regex => 1 + +Values will be checked against any regexes provided. + +=back + +=back + +=head1 WRITING A VARIANT OF IS/LIKE + + use Test2::Compare qw/compare convert/; + + sub my_like($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + # A custom converter that does the same thing as the one used by like() + my $convert = sub { + my $thing = shift; + return convert( + $thing, + { + implicit_end => 0, + use_code => 1, + use_regex => 1, + } + ); + }; + + my $delta = compare($got, $exp, $convert); + + if ($delta) { + $ctx->fail($name, $delta->diag, @diag); + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; + } + +The work of a comparison tool is done by 3 entities: + +=over 4 + +=item compare() + +The C function takes the structure you got, the specification you +want to check against, and a C<\&convert> sub that will convert anything that +is not an instance of an L subclass into one. + +This tool will use the C<\&convert> function on the specification, and then +produce an L structure that outlines all the ways the +structure you got deviates from the specification. + +=item \&convert + +Converts anything that is not an instance of an L +subclass, and turns it into one. The objects this produces are able to check +that a structure matches a specification. + +=item $delta + +An instance of L is ultimately returned. This object +represents all the ways in with the structure you got deviated from the +specification. The delta is a tree and may contain child deltas for nested +structures. + +The delta is capable of rendering itself as a table, use C<< @lines = +$delta->diag >> to get the table (lines in C<@lines> will not be terminated +with C<"\n">). + +=back + +The C function provided by this package contains all the +specification behavior of C and C. It is intended to be wrapped +in a sub that passes in a configuration hash, which allows you to control the +behavior. + +You are free to write your own C<$check = compare($thing)> function, it just +needs to accept a single argument, and produce a single instance of an +L subclass. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Array.pm b/cpan/Test2-Suite/lib/Test2/Compare/Array.pm new file mode 100644 index 000000000000..4d0858c771f1 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Array.pm @@ -0,0 +1,328 @@ +package Test2::Compare::Array; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/inref meta ending items order for_each/; + +use Carp qw/croak confess/; +use Scalar::Util qw/reftype looks_like_number/; + +sub init { + my $self = shift; + + if( defined( my $ref = $self->{+INREF}) ) { + croak "Cannot specify both 'inref' and 'items'" if $self->{+ITEMS}; + croak "Cannot specify both 'inref' and 'order'" if $self->{+ORDER}; + croak "'inref' must be an array reference, got '$ref'" unless reftype($ref) eq 'ARRAY'; + my $order = $self->{+ORDER} = []; + my $items = $self->{+ITEMS} = {}; + for (my $i = 0; $i < @$ref; $i++) { + push @$order => $i; + $items->{$i} = $ref->[$i]; + } + } + else { + $self->{+ITEMS} ||= {}; + croak "All indexes listed in the 'items' hashref must be numeric" + if grep { !looks_like_number($_) } keys %{$self->{+ITEMS}}; + + $self->{+ORDER} ||= [sort { $a <=> $b } keys %{$self->{+ITEMS}}]; + croak "All indexes listed in the 'order' arrayref must be numeric" + if grep { !(looks_like_number($_) || (ref($_) && reftype($_) eq 'CODE')) } @{$self->{+ORDER}}; + } + + $self->{+FOR_EACH} ||= []; + + $self->SUPER::init(); +} + +sub name { '' } + +sub meta_class { 'Test2::Compare::Meta' } + +sub verify { + my $self = shift; + my %params = @_; + + return 0 unless $params{exists}; + my $got = $params{got}; + return 0 unless defined $got; + return 0 unless ref($got); + return 0 unless reftype($got) eq 'ARRAY'; + return 1; +} + +sub add_prop { + my $self = shift; + $self->{+META} = $self->meta_class->new unless defined $self->{+META}; + $self->{+META}->add_prop(@_); +} + +sub top_index { + my $self = shift; + my @order = @{$self->{+ORDER}}; + + while(@order) { + my $idx = pop @order; + next if ref $idx; + return $idx; + } + + return undef; # No indexes +} + +sub add_item { + my $self = shift; + my $check = pop; + my ($idx) = @_; + + my $top = $self->top_index; + + croak "elements must be added in order!" + if $top && $idx && $idx <= $top; + + $idx = defined($top) ? $top + 1 : 0 + unless defined($idx); + + push @{$self->{+ORDER}} => $idx; + $self->{+ITEMS}->{$idx} = $check; +} + +sub add_filter { + my $self = shift; + my ($code) = @_; + croak "A single coderef is required" + unless @_ == 1 && $code && ref $code && reftype($code) eq 'CODE'; + + push @{$self->{+ORDER}} => $code; +} + +sub add_for_each { + my $self = shift; + push @{$self->{+FOR_EACH}} => @_; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my @deltas; + my $state = 0; + my @order = @{$self->{+ORDER}}; + my $items = $self->{+ITEMS}; + my $for_each = $self->{+FOR_EACH}; + + my $meta = $self->{+META}; + push @deltas => $meta->deltas(%params) if defined $meta; + + # Make a copy that we can munge as needed. + my @list = @$got; + + while (@order) { + my $idx = shift @order; + my $overflow = 0; + my $val; + + # We have a filter, not an index + if (ref($idx)) { + @list = $idx->(@list); + next; + } + + confess "Internal Error: Stacks are out of sync (state > idx)" + if $state > $idx + 1; + + while ($state <= $idx) { + $overflow = !@list; + $val = shift @list; + + # check-all goes here so we hit each item, even unspecified ones. + for my $check (@$for_each) { + $check = $convert->($check); + push @deltas => $check->run( + id => [ARRAY => $state], + convert => $convert, + seen => $seen, + exists => !$overflow, + $overflow ? () : (got => $val), + ); + } + + $state++; + } + + confess "Internal Error: Stacks are out of sync (state != idx + 1)" + unless $state == $idx + 1; + + my $check = $convert->($items->{$idx}); + + push @deltas => $check->run( + id => [ARRAY => $idx], + convert => $convert, + seen => $seen, + exists => !$overflow, + $overflow ? () : (got => $val), + ); + } + + while (@list && (@$for_each || $self->{+ENDING})) { + my $item = shift @list; + + for my $check (@$for_each) { + $check = $convert->($check); + push @deltas => $check->run( + id => [ARRAY => $state], + convert => $convert, + seen => $seen, + got => $item, + exists => 1, + ); + } + + # if items are left over, and ending is true, we have a problem! + if ($self->{+ENDING}) { + push @deltas => $self->delta_class->new( + dne => 'check', + verified => undef, + id => [ARRAY => $state], + got => $item, + check => undef, + + $self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (), + ); + } + + $state++; + } + + return @deltas; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Array - Internal representation of an array comparison. + +=head1 DESCRIPTION + +This module is an internal representation of an array for comparison purposes. + +=head1 METHODS + +=over 4 + +=item $ref = $arr->inref() + +If the instance was constructed from an actual array, this will return the +reference to that array. + +=item $bool = $arr->ending + +=item $arr->set_ending($bool) + +Set this to true if you would like to fail when the array being validated has +more items than the check. That is, if you check indexes 0-3 but the array has +values for indexes 0-4, it will fail and list that last item in the array as +unexpected. If set to false then it is assumed you do not care about extra +items. + +=item $hashref = $arr->items() + +Returns the hashref of C<< key => val >> pairs to be checked in the +array. + +=item $arr->set_items($hashref) + +Accepts a hashref to permit indexes to be skipped if desired. + +B that there is no validation when using C, it is better to +use the C interface. + +=item $arrayref = $arr->order() + +Returns an arrayref of all indexes that will be checked, in order. + +=item $arr->set_order($arrayref) + +Sets the order in which indexes will be checked. + +B that there is no validation when using C, it is better to +use the C interface. + +=item $name = $arr->name() + +Always returns the string C<< "" >>. + +=item $bool = $arr->verify(got => $got, exists => $bool) + +Check if C<$got> is an array reference or not. + +=item $idx = $arr->top_index() + +Returns the topmost index which is checked. This will return undef if there +are no items, or C<0> if there is only 1 item. + +=item $arr->add_item($item) + +Push an item onto the list of values to be checked. + +=item $arr->add_item($idx => $item) + +Add an item to the list of values to be checked at the specified index. + +=item $arr->add_filter(sub { ... }) + +Add a filter sub. The filter receives all remaining values of the array being +checked, and should return the values that should still be checked. The filter +will be run between the last item added and the next item added. + +=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen) + +Find the differences between the expected array values and those in the C<$got> +arrayref. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Bag.pm b/cpan/Test2-Suite/lib/Test2/Compare/Bag.pm new file mode 100644 index 000000000000..2b057a4b7908 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Bag.pm @@ -0,0 +1,244 @@ +package Test2::Compare::Bag; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/ending meta items for_each/; + +use Carp qw/croak confess/; +use Scalar::Util qw/reftype looks_like_number/; + +sub init { + my $self = shift; + + $self->{+ITEMS} ||= []; + $self->{+FOR_EACH} ||= []; + + $self->SUPER::init(); +} + +sub name { '' } + +sub meta_class { 'Test2::Compare::Meta' } + +sub verify { + my $self = shift; + my %params = @_; + + return 0 unless $params{exists}; + my $got = $params{got} || return 0; + return 0 unless ref($got); + return 0 unless reftype($got) eq 'ARRAY'; + return 1; +} + +sub add_prop { + my $self = shift; + $self->{+META} = $self->meta_class->new unless defined $self->{+META}; + $self->{+META}->add_prop(@_); +} + +sub add_item { + my $self = shift; + my $check = pop; + my ($idx) = @_; + + push @{$self->{+ITEMS}}, $check; +} + +sub add_for_each { + my $self = shift; + push @{$self->{+FOR_EACH}} => @_; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my @deltas; + my $state = 0; + my @items = @{$self->{+ITEMS}}; + my @for_each = @{$self->{+FOR_EACH}}; + + # Make a copy that we can munge as needed. + my @list = @$got; + my %unmatched = map { $_ => $list[$_] } 0..$#list; + + my $meta = $self->{+META}; + push @deltas => $meta->deltas(%params) if defined $meta; + + while (@items) { + my $item = shift @items; + + my $check = $convert->($item); + + my $match = 0; + for my $idx (0..$#list) { + next unless exists $unmatched{$idx}; + my $val = $list[$idx]; + my $deltas = $check->run( + id => [ARRAY => $idx], + convert => $convert, + seen => $seen, + exists => 1, + got => $val, + ); + + unless ($deltas) { + $match++; + delete $unmatched{$idx}; + last; + } + } + unless ($match) { + push @deltas => $self->delta_class->new( + dne => 'got', + verified => undef, + id => [ARRAY => '*'], + got => undef, + check => $check, + ); + } + } + + if (@for_each) { + my @checks = map { $convert->($_) } @for_each; + + for my $idx (0..$#list) { + # All items are matched if we have conditions for all items + delete $unmatched{$idx}; + + my $val = $list[$idx]; + + for my $check (@checks) { + push @deltas => $check->run( + id => [ARRAY => $idx], + convert => $convert, + seen => $seen, + exists => 1, + got => $val, + ); + } + } + } + + # if elements are left over, and ending is true, we have a problem! + if($self->{+ENDING} && keys %unmatched) { + for my $idx (sort keys %unmatched) { + my $elem = $list[$idx]; + push @deltas => $self->delta_class->new( + dne => 'check', + verified => undef, + id => [ARRAY => $idx], + got => $elem, + check => undef, + + $self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (), + ); + } + } + + return @deltas; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Bag - Internal representation of a bag comparison. + +=head1 DESCRIPTION + +This module is an internal representation of a bag for comparison purposes. + +=head1 METHODS + +=over 4 + +=item $bool = $arr->ending + +=item $arr->set_ending($bool) + +Set this to true if you would like to fail when the array being validated has +more items than the check. That is, if you check for 4 items but the array has +5 values, it will fail and list that unmatched item in the array as +unexpected. If set to false then it is assumed you do not care about extra +items. + +=item $arrayref = $arr->items() + +Returns the arrayref of values to be checked in the array. + +=item $arr->set_items($arrayref) + +Accepts an arrayref. + +B that there is no validation when using C, it is better to +use the C interface. + +=item $name = $arr->name() + +Always returns the string C<< "" >>. + +=item $bool = $arr->verify(got => $got, exists => $bool) + +Check if C<$got> is an array reference or not. + +=item $arr->add_item($item) + +Push an item onto the list of values to be checked. + +=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen) + +Find the differences between the expected bag values and those in the C<$got> +arrayref. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Gianni Ceccarelli Edakkar@thenautilus.netE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Gianni Ceccarelli Edakkar@thenautilus.netE + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum Eexodist@cpan.orgE. + +Copyright 2018 Gianni Ceccarelli Edakkar@thenautilus.netE + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/Compare/Base.pm b/cpan/Test2-Suite/lib/Test2/Compare/Base.pm new file mode 100644 index 000000000000..74f9981a34a5 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Base.pm @@ -0,0 +1,252 @@ +package Test2::Compare::Base; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/confess croak/; +use Scalar::Util qw/blessed/; + +use Test2::Util::Sub qw/sub_info/; +use Test2::Compare::Delta(); + +sub MAX_CYCLES() { 75 } + +use Test2::Util::HashBase qw{builder _file _lines _info called}; +use Test2::Util::Ref qw/render_ref/; + +{ + no warnings 'once'; + *set_lines = \&set__lines; + *set_file = \&set__file; +} + +sub clone { + my $self = shift; + my $class = blessed($self); + + # Shallow copy is good enough for all the current compare types. + return bless({%$self}, $class); +} + +sub init { + my $self = shift; + $self->{+_LINES} = delete $self->{lines} if exists $self->{lines}; + $self->{+_FILE} = delete $self->{file} if exists $self->{file}; +} + +sub file { + my $self = shift; + return $self->{+_FILE} if $self->{+_FILE}; + + if ($self->{+BUILDER}) { + $self->{+_INFO} ||= sub_info($self->{+BUILDER}); + return $self->{+_INFO}->{file}; + } + elsif ($self->{+CALLED}) { + return $self->{+CALLED}->[1]; + } + + return undef; +} + +sub lines { + my $self = shift; + return $self->{+_LINES} if $self->{+_LINES}; + + if ($self->{+BUILDER}) { + $self->{+_INFO} ||= sub_info($self->{+BUILDER}); + return $self->{+_INFO}->{lines} if @{$self->{+_INFO}->{lines}}; + } + if ($self->{+CALLED}) { + return [$self->{+CALLED}->[2]]; + } + return []; +} + +sub delta_class { 'Test2::Compare::Delta' } + +sub deltas { () } +sub got_lines { () } + +sub stringify_got { 0 } + +sub operator { '' } +sub verify { confess "unimplemented" } +sub name { confess "unimplemented" } + +sub render { + my $self = shift; + return $self->name; +} + +sub run { + my $self = shift; + my %params = @_; + + my $id = $params{id}; + my $convert = $params{convert} or confess "no convert sub provided"; + my $seen = $params{seen} ||= {}; + + $params{exists} = exists $params{got} ? 1 : 0 + unless exists $params{exists}; + + my $exists = $params{exists}; + my $got = $exists ? $params{got} : undef; + + my $gotname = render_ref($got); + + # Prevent infinite cycles + if (defined($got) && ref $got) { + die "Cycle detected in comparison, aborting" + if $seen->{$gotname} && $seen->{$gotname} >= MAX_CYCLES; + $seen->{$gotname}++; + } + + my $ok = $self->verify(%params); + my @deltas = $ok ? $self->deltas(%params) : (); + + $seen->{$gotname}-- if defined $got && ref $got; + + return if $ok && !@deltas; + + return $self->delta_class->new( + verified => $ok, + id => $id, + got => $got, + check => $self, + children => \@deltas, + $exists ? () : (dne => 'got'), + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Base - Base class for comparison classes. + +=head1 DESCRIPTION + +All comparison classes for Test2::Compare should inherit from this base class. + +=head1 SYNOPSIS + + package Test2::Compare::MyCheck; + use strict; + use warnings; + + use base 'Test2::Compare::Base'; + use Test2::Util::HashBase qw/stuff/; + + sub name { 'STUFF' } + + sub operator { + my $self = shift; + my ($got) = @_; + return 'eq'; + } + + sub verify { + my $self = shift; + my $params = @_; + + # Always check if $got exists! This method must return false if no + # value at all was received. + return 0 unless $params{exists}; + + my $got = $params{got}; + + # Returns true if both values match. This includes undef, 0, and other + # false-y values! + return $got eq $self->stuff; + } + +=head1 METHODS + +Some of these must be overridden, others can be. + +=over 4 + +=item $dclass = $check->delta_class + +Returns the delta subclass that should be used. By default +L is used. + +=item @deltas = $check->deltas(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen) + +Should return child deltas. + +=item @lines = $check->got_lines($got) + +This is your chance to provide line numbers for errors in the C<$got> +structure. + +=item $op = $check->operator() + +=item $op = $check->operator($got) + +Returns the operator that was used to compare the check with the received data +in C<$got>. If there was no value for got then there will be no arguments, +undef will only be an argument if undef was seen in C<$got>. This is how you +can tell the difference between a missing value and an undefined one. + +=item $bool = $check->verify(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen) + +Return true if there is a shallow match, that is both items are arrayrefs, both +items are the same string or same number, etc. This should not recurse, as deep +checks are done in C<< $check->deltas() >>. + +=item $name = $check->name + +Get the name of the check. + +=item $display = $check->render + +What should be displayed in a table for this check, usually the name or value. + +=item $delta = $check->run(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen) + +This is where the checking is done, first a shallow check using +C<< $check->verify >>, then checking C<< $check->deltas() >>. C<\%seen> is used +to prevent cycles. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Bool.pm b/cpan/Test2-Suite/lib/Test2/Compare/Bool.pm new file mode 100644 index 000000000000..eac7d8f240d5 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Bool.pm @@ -0,0 +1,111 @@ +package Test2::Compare::Bool; +use strict; +use warnings; + +use Carp qw/confess/; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/input/; + +# Overloads '!' for us. +use Test2::Compare::Negatable; + +sub name { + my $self = shift; + my $in = $self->{+INPUT}; + return _render_bool($in); +} + +sub operator { + my $self = shift; + return '!=' if $self->{+NEGATE}; + return '=='; +} + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + + my $want = $self->{+INPUT}; + + my $match = ($want xor $got) ? 0 : 1; + $match = $match ? 0 : 1 if $self->{+NEGATE}; + + return $match; +} + +sub run { + my $self = shift; + my $delta = $self->SUPER::run(@_) or return; + + my $dne = $delta->dne || ""; + unless ($dne eq 'got') { + my $got = $delta->got; + $delta->set_got(_render_bool($got)); + } + + return $delta; +} + +sub _render_bool { + my $bool = shift; + my $name = $bool ? 'TRUE' : 'FALSE'; + my $val = defined $bool ? $bool : 'undef'; + $val = "''" unless length($val); + + return "<$name ($val)>"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Bool - Compare two values as booleans + +=head1 DESCRIPTION + +Check if two values have the same boolean result (both true, or both false). + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Custom.pm b/cpan/Test2-Suite/lib/Test2/Compare/Custom.pm new file mode 100644 index 000000000000..3fa813e8db8d --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Custom.pm @@ -0,0 +1,182 @@ +package Test2::Compare::Custom; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/code name operator stringify_got/; + +use Carp qw/croak/; + +sub init { + my $self = shift; + + croak "'code' is required" unless $self->{+CODE}; + + $self->{+OPERATOR} ||= 'CODE(...)'; + $self->{+NAME} ||= ''; + $self->{+STRINGIFY_GOT} = $self->SUPER::stringify_got() + unless defined $self->{+STRINGIFY_GOT}; + + $self->SUPER::init(); +} + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + my $code = $self->{+CODE}; + + local $_ = $got; + my $ok = $code->( + got => $got, + exists => $exists, + operator => $self->{+OPERATOR}, + name => $self->{+NAME}, + ); + + return $ok; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Custom - Custom field check for comparisons. + +=head1 DESCRIPTION + +Sometimes you want to do something complicated or unusual when validating a +field nested inside a deep data structure. You could pull it out of the +structure and test it separately, or you can use this to embed the check. This +provides a way for you to write custom checks for fields in deep comparisons. + +=head1 SYNOPSIS + + my $cus = Test2::Compare::Custom->new( + name => 'IsRef', + operator => 'ref(...)', + stringify_got => 1, + code => sub { + my %args = @_; + return $args{got} ? 1 : 0; + }, + ); + + # Pass + is( + { a => 1, ref => {}, b => 2 }, + { a => 1, ref => $cus, b => 2 }, + "This will pass" + ); + + # Fail + is( + {a => 1, ref => 'notref', b => 2}, + {a => 1, ref => $cus, b => 2}, + "This will fail" + ); + +=head1 ARGUMENTS + +Your custom sub will be passed 4 arguments in a hash: + + code => sub { + my %args = @_; + # provides got, exists, operator, name + return ref($args{got}) ? 1 : 0; + }, + +C<$_> is also localized to C to make it easier for those who need to use +regexes. + +=over 4 + +=item got + +=item $_ + +The value to be checked. + +=item exists + +This will be a boolean. This will be true if C exists at all. If +C is false then it means C is not simply undef, but doesn't +exist at all (think checking the value of a hash key that does not exist). + +=item operator + +The operator specified at construction. + +=item name + +The name provided at construction. + +=back + +=head1 METHODS + +=over 4 + +=item $code = $cus->code + +Returns the coderef provided at construction. + +=item $name = $cus->name + +Returns the name provided at construction. + +=item $op = $cus->operator + +Returns the operator provided at construction. + +=item $stringify = $cus->stringify_got + +Returns the stringify_got flag provided at construction. + +=item $bool = $cus->verify(got => $got, exists => $bool) + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 Daniel Böhmer Edboehmer@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2018 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/cpan/Test2-Suite/lib/Test2/Compare/DeepRef.pm b/cpan/Test2-Suite/lib/Test2/Compare/DeepRef.pm new file mode 100644 index 000000000000..a6453923a844 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/DeepRef.pm @@ -0,0 +1,119 @@ +package Test2::Compare::DeepRef; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/input/; + +use Test2::Util::Ref qw/render_ref rtype/; +use Scalar::Util qw/refaddr/; +use Carp qw/croak/; + +sub init { + my $self = shift; + + croak "'input' is a required attribute" + unless $self->{+INPUT}; + + croak "'input' must be a reference, got '" . $self->{+INPUT} . "'" + unless ref $self->{+INPUT}; + + $self->SUPER::init(); +} + +sub name { '' } + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + + my $in = $self->{+INPUT}; + return 0 unless ref $in; + return 0 unless ref $got; + + my $in_type = rtype($in); + my $got_type = rtype($got); + + return 0 unless $in_type eq $got_type; + + return 1; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my $in = $self->{+INPUT}; + my $in_type = rtype($in); + my $got_type = rtype($got); + + my $check = $convert->($$in); + + return $check->run( + id => ['DEREF' => '$*'], + convert => $convert, + seen => $seen, + got => $$got, + exists => 1, + ); +} + + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::DeepRef - Ref comparison + +=head1 DESCRIPTION + +Used to compare two refs in a deep comparison. + +=head1 SYNOPSIS + + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Delta.pm b/cpan/Test2-Suite/lib/Test2/Compare/Delta.pm new file mode 100644 index 000000000000..9505f4249bec --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Delta.pm @@ -0,0 +1,558 @@ +package Test2::Compare::Delta; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw{verified id got chk children dne exception note}; + +use Test2::EventFacet::Info::Table; + +use Test2::Util::Table(); +use Test2::API qw/context/; + +use Test2::Util::Ref qw/render_ref rtype/; +use Carp qw/croak/; + +# 'CHECK' constant would not work, but I like exposing 'check()' to people +# using this class. +BEGIN { + no warnings 'once'; + *check = \&chk; + *set_check = \&set_chk; +} + +my @COLUMN_ORDER = qw/PATH GLNs GOT OP CHECK CLNs/; +my %COLUMNS = ( + GOT => {name => 'GOT', value => sub { $_[0]->render_got }, no_collapse => 1}, + CHECK => {name => 'CHECK', value => sub { $_[0]->render_check }, no_collapse => 1}, + OP => {name => 'OP', value => sub { $_[0]->table_op } }, + PATH => {name => 'PATH', value => sub { $_[1] } }, + + 'GLNs' => {name => 'GLNs', alias => 'LNs', value => sub { $_[0]->table_got_lines } }, + 'CLNs' => {name => 'CLNs', alias => 'LNs', value => sub { $_[0]->table_check_lines }}, +); +{ + my $i = 0; + $COLUMNS{$_}->{id} = $i++ for @COLUMN_ORDER; +} + +sub remove_column { + my $class = shift; + my $header = shift; + @COLUMN_ORDER = grep { $_ ne $header } @COLUMN_ORDER; + delete $COLUMNS{$header} ? 1 : 0; +} + +sub add_column { + my $class = shift; + my $name = shift; + + croak "Column name is required" + unless $name; + + croak "Column '$name' is already defined" + if $COLUMNS{$name}; + + my %params; + if (@_ == 1) { + %params = (value => @_, name => $name); + } + else { + %params = (@_, name => $name); + } + + my $value = $params{value}; + + croak "You must specify a 'value' callback" + unless $value; + + croak "'value' callback must be a CODE reference" + unless rtype($value) eq 'CODE'; + + if ($params{prefix}) { + unshift @COLUMN_ORDER => $name; + } + else { + push @COLUMN_ORDER => $name; + } + + $COLUMNS{$name} = \%params; +} + +sub set_column_alias { + my ($class, $name, $alias) = @_; + + croak "Tried to alias a non-existent column" + unless exists $COLUMNS{$name}; + + croak "Missing alias" unless defined $alias; + + $COLUMNS{$name}->{alias} = $alias; +} + +sub init { + my $self = shift; + + croak "Cannot specify both 'check' and 'chk' as arguments" + if exists($self->{check}) && exists($self->{+CHK}); + + # Allow 'check' as an argument + $self->{+CHK} ||= delete $self->{check} + if exists $self->{check}; +} + +sub render_got { + my $self = shift; + + my $exp = $self->{+EXCEPTION}; + if ($exp) { + chomp($exp = "$exp"); + $exp =~ s/\n.*$//g; + return ""; + } + + my $dne = $self->{+DNE}; + return '' if $dne && $dne eq 'got'; + + my $got = $self->{+GOT}; + return '' unless defined $got; + + my $check = $self->{+CHK}; + my $stringify = defined( $check ) && $check->stringify_got; + + return render_ref($got) if ref $got && !$stringify; + + return "$got"; +} + +sub render_check { + my $self = shift; + + my $dne = $self->{+DNE}; + return '' if $dne && $dne eq 'check'; + + my $check = $self->{+CHK}; + return '' unless defined $check; + + return $check->render; +} + +sub _full_id { + my ($type, $id) = @_; + return "<$id>" if !$type || $type eq 'META'; + return $id if $type eq 'SCALAR'; + return "{$id}" if $type eq 'HASH'; + return "{$id} " if $type eq 'HASHKEY'; + return "[$id]" if $type eq 'ARRAY'; + return "$id()" if $type eq 'METHOD'; + return "$id" if $type eq 'DEREF'; + return "<$id>"; +} + +sub _arrow_id { + my ($path, $type) = @_; + return '' unless $path; + + return ' ' if !$type || $type eq 'META'; # Meta gets a space, not an arrow + + return '->' if $type eq 'METHOD'; # Method always needs an arrow + return '->' if $type eq 'SCALAR'; # Scalar always needs an arrow + return '->' if $type eq 'DEREF'; # deref always needs arrow + return '->' if $path =~ m/(>|\(\))$/; # Need an arrow after meta, or after a method + return '->' if $path eq '$VAR'; # Need an arrow after the initial ref + + # Hash and array need an arrow unless they follow another hash/array + return '->' if $type =~ m/^(HASH|ARRAY)$/ && $path !~ m/(\]|\})$/; + + # No arrow needed + return ''; +} + +sub _join_id { + my ($path, $parts) = @_; + my ($type, $key) = @$parts; + + my $id = _full_id($type, $key); + my $join = _arrow_id($path, $type); + + return "${path}${join}${id}"; +} + +sub should_show { + my $self = shift; + return 1 unless $self->verified; + defined( my $check = $self->check ) || return 0; + return 0 unless $check->lines; + my $file = $check->file || return 0; + + my $ctx = context(); + my $cfile = $ctx->trace->file; + $ctx->release; + return 0 unless $file eq $cfile; + + return 1; +} + +sub filter_visible { + my $self = shift; + + my @deltas; + my @queue = (['', $self]); + + while (my $set = shift @queue) { + my ($path, $delta) = @$set; + + push @deltas => [$path, $delta] if $delta->should_show; + + my $children = $delta->children || next; + next unless @$children; + + my @new; + for my $child (@$children) { + my $cpath = _join_id($path, $child->id); + push @new => [$cpath, $child]; + } + unshift @queue => @new; + } + + return \@deltas; +} + +sub table_header { [map {$COLUMNS{$_}->{alias} || $_} @COLUMN_ORDER] } + +sub table_op { + my $self = shift; + + defined( my $check = $self->{+CHK} ) || return '!exists'; + + return $check->operator($self->{+GOT}) + unless $self->{+DNE} && $self->{+DNE} eq 'got'; + + return $check->operator(); +} + +sub table_check_lines { + my $self = shift; + + defined( my $check = $self->{+CHK} ) || return ''; + my $lines = $check->lines || return ''; + + return '' unless @$lines; + + return join ', ' => @$lines; +} + +sub table_got_lines { + my $self = shift; + + defined( my $check = $self->{+CHK} ) || return ''; + return '' if $self->{+DNE} && $self->{+DNE} eq 'got'; + + my @lines = $check->got_lines($self->{+GOT}); + return '' unless @lines; + + return join ', ' => @lines; +} + +sub table_rows { + my $self = shift; + + my $deltas = $self->filter_visible; + + my @rows; + for my $set (@$deltas) { + my ($id, $d) = @$set; + + my @row; + for my $col (@COLUMN_ORDER) { + my $spec = $COLUMNS{$col}; + my $val = $spec->{value}->($d, $id); + $val = '' unless defined $val; + push @row => $val; + } + + push @rows => \@row; + } + + return \@rows; +} + +sub table { + my $self = shift; + + my @diag; + my $header = $self->table_header; + my $rows = $self->table_rows; + + my $render_rows = [@$rows]; + my $max = exists $ENV{TS_MAX_DELTA} ? $ENV{TS_MAX_DELTA} : 25; + if ($max && @$render_rows > $max) { + @$render_rows = map { [@$_] } @{$render_rows}[0 .. ($max - 1)]; + @diag = ( + "************************************************************", + sprintf("* Stopped after %-42.42s *", "$max differences."), + "* Set the TS_MAX_DELTA environment var to raise the limit. *", + "* Set it to 0 for no limit. *", + "************************************************************", + ); + } + + my @dne; + for my $row (@$render_rows) { + my $got = $row->[$COLUMNS{GOT}->{id}] || ''; + my $chk = $row->[$COLUMNS{CHECK}->{id}] || ''; + if ($got eq '') { + push @dne => "$row->[$COLUMNS{PATH}->{id}]: DOES NOT EXIST"; + } + elsif ($chk eq '') { + push @dne => "$row->[$COLUMNS{PATH}->{id}]: SHOULD NOT EXIST"; + } + } + + if (@dne) { + unshift @dne => '==== Summary of missing/extra items ===='; + push @dne => '== end summary of missing/extra items =='; + } + + my $table_args = { + header => $header, + collapse => 1, + sanitize => 1, + mark_tail => 1, + no_collapse => [grep { $COLUMNS{$COLUMN_ORDER[$_]}->{no_collapse} } 0 .. $#COLUMN_ORDER], + }; + + my $render = join "\n" => ( + Test2::Util::Table::table(%$table_args, rows => $render_rows), + @dne, + @diag, + ); + + my $table = Test2::EventFacet::Info::Table->new( + %$table_args, + rows => $rows, + as_string => $render, + ); + + return $table; +} + +sub diag { shift->table } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Delta - Representation of differences between nested data +structures. + +=head1 DESCRIPTION + +This is used by L. When data structures are compared a +delta will be returned. Deltas are a tree data structure that represent all the +differences between two other data structures. + +=head1 METHODS + +=head2 CLASS METHODS + +=over 4 + +=item $class->add_column($NAME => sub { ... }) + +=item $class->add_column($NAME, %PARAMS) + +This can be used to add columns to the table that it produced when a comparison +fails. The first argument should always be the column name, which must be +unique. + +The first form simply takes a coderef that produces the value that should be +displayed in the column for any given delta. The arguments passed into the sub +are the delta, and the row ID. + + Test2::Compare::Delta->add_column( + Foo => sub { + my ($delta, $id) = @_; + return $delta->... ? 'foo' : 'bar' + }, + ); + +The second form allows you some extra options. The C<'value'> key is required, +and must be a coderef. All other keys are optional. + + Test2::Compare::Delta->add_column( + 'Foo', # column name + value => sub { ... }, # how to get the cell value + alias => 'FOO', # Display name (used in table header) + no_collapse => $bool, # Show column even if it has no values? + ); + +=item $bool = $class->remove_column($NAME) + +This will remove the specified column. This will return true if the column +existed and was removed. This will return false if the column did not exist. No +exceptions are thrown. If a missing column is a problem then you need to check +the return yourself. + +=item $class->set_column_alias($NAME, $ALIAS) + +This can be used to change the table header, overriding the default column +names with new ones. + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item $bool = $delta->verified + +=item $delta->set_verified($bool) + +This will be true if the delta itself matched, if the delta matched then the +problem is in the delta's children, not the delta itself. + +=item $aref = $delta->id + +=item $delta->set_id([$type, $name]) + +ID for the delta, used to produce the path into the data structure. An +example is C<< ['HASH' => 'foo'] >> which means the delta is in the path +C<< ...->{'foo'} >>. Valid types are C, C, C, C, and +C. + +=item $val = $delta->got + +=item $delta->set_got($val) + +Deltas are produced by comparing a received data structure 'got' against a +check data structure 'check'. The 'got' attribute contains the value that was +received for comparison. + +=item $check = $delta->chk + +=item $check = $delta->check + +=item $delta->set_chk($check) + +=item $delta->set_check($check) + +Deltas are produced by comparing a received data structure 'got' against a +check data structure 'check'. The 'check' attribute contains the value that was +expected in the comparison. + +C and C are aliases for the same attribute. + +=item $aref = $delta->children + +=item $delta->set_children([$delta1, $delta2, ...]) + +A Delta may have child deltas. If it does then this is an arrayref with those +children. + +=item $dne = $delta->dne + +=item $delta->set_dne($dne) + +Sometimes a comparison results in one side or the other not existing at all, in +which case this is set to the name of the attribute that does not exist. This +can be set to 'got' or 'check'. + +=item $e = $delta->exception + +=item $delta->set_exception($e) + +This will be set to the exception in cases where the comparison failed due to +an exception being thrown. + +=back + +=head2 OTHER + +=over 4 + +=item $string = $delta->render_got + +Renders the string that should be used in a table to represent the received +value in a comparison. + +=item $string = $delta->render_check + +Renders the string that should be used in a table to represent the expected +value in a comparison. + +=item $bool = $delta->should_show + +This will return true if the delta should be shown in the table. This is +normally true for any unverified delta. This will also be true for deltas that +contain extra useful debug information. + +=item $aref = $delta->filter_visible + +This will produce an arrayref of C<< [ $path => $delta ] >> for all deltas that +should be displayed in the table. + +=item $aref = $delta->table_header + +This returns an array ref of the headers for the table. + +=item $string = $delta->table_op + +This returns the operator that should be shown in the table. + +=item $string = $delta->table_check_lines + +This returns the defined lines (extra debug info) that should be displayed. + +=item $string = $delta->table_got_lines + +This returns the generated lines (extra debug info) that should be displayed. + +=item $aref = $delta->table_rows + +This returns an arrayref of table rows, each row is itself an arrayref. + +=item @table_lines = $delta->table + +Returns all the lines of the table that should be displayed. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Event.pm b/cpan/Test2-Suite/lib/Test2/Compare/Event.pm new file mode 100644 index 000000000000..8224e2024c1c --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Event.pm @@ -0,0 +1,81 @@ +package Test2::Compare::Event; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; + +use Test2::Compare::EventMeta(); + +use base 'Test2::Compare::Object'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/etype/; + +sub name { + my $self = shift; + my $etype = $self->etype; + return ""; +} + +sub meta_class { 'Test2::Compare::EventMeta' } +sub object_base { 'Test2::Event' } + +sub got_lines { + my $self = shift; + my ($event) = @_; + return unless $event; + return unless blessed($event); + return unless $event->isa('Test2::Event'); + return unless $event->trace; + + return ($event->trace->line); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Event - Event specific Object subclass. + +=head1 DESCRIPTION + +This module is used to represent an expected event in a deep comparison. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/EventMeta.pm b/cpan/Test2-Suite/lib/Test2/Compare/EventMeta.pm new file mode 100644 index 000000000000..0e08ea3db827 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/EventMeta.pm @@ -0,0 +1,100 @@ +package Test2::Compare::EventMeta; +use strict; +use warnings; + +use base 'Test2::Compare::Meta'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase; + +sub get_prop_file { $_[1]->trace->file } +sub get_prop_line { $_[1]->trace->line } +sub get_prop_package { $_[1]->trace->package } +sub get_prop_subname { $_[1]->trace->subname } +sub get_prop_debug { $_[1]->trace->debug } +sub get_prop_tid { $_[1]->trace->tid } +sub get_prop_pid { $_[1]->trace->pid } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::EventMeta - Meta class for events in deep comparisons + +=head1 DESCRIPTION + +This is used in deep comparisons of event objects. You should probably never +use this directly. + +=head1 DEFINED CHECKS + +=over 4 + +=item file + +File that generated the event. + +=item line + +Line where the event was generated. + +=item package + +Package that generated the event. + +=item subname + +Name of the tool that generated the event. + +=item debug + +The debug information that will be printed in event of a failure. + +=item tid + +Thread ID of the thread that generated the event. + +=item pid + +Process ID of the process that generated the event. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Float.pm b/cpan/Test2-Suite/lib/Test2/Compare/Float.pm new file mode 100644 index 000000000000..fad01721593e --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Float.pm @@ -0,0 +1,177 @@ +package Test2::Compare::Float; +use strict; +use warnings; + +use Carp qw/confess/; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +our $DEFAULT_TOLERANCE = 1e-08; + +use Test2::Util::HashBase qw/input tolerance precision/; + +# Overloads '!' for us. +use Test2::Compare::Negatable; + +sub init { + my $self = shift; + my $input = $self->{+INPUT}; + + if ( exists $self->{+TOLERANCE} and exists $self->{+PRECISION} ) { + confess "can't set both tolerance and precision"; + } elsif (!exists $self->{+PRECISION} and !exists $self->{+TOLERANCE}) { + $self->{+TOLERANCE} = $DEFAULT_TOLERANCE + } + + confess "input must be defined for 'Float' check" + unless defined $input; + + # Check for '' + confess "input must be a number for 'Float' check" + unless length($input) && $input =~ m/\S/; + + confess "precision must be an integer for 'Float' check" + if exists $self->{+PRECISION} && $self->{+PRECISION} !~ m/^\d+$/; + + $self->SUPER::init(@_); +} + +sub name { + my $self = shift; + my $in = $self->{+INPUT}; + my $precision = $self->{+PRECISION}; + if ( defined $precision) { + return sprintf "%.*f", $precision, $in; + } + my $tolerance = $self->{+TOLERANCE}; + return "$in +/- $tolerance"; +} + +sub operator { + my $self = shift; + return '' unless @_; + my ($got) = @_; + + return '' unless defined($got); + return '' unless length($got) && $got =~ m/\S/; + + if ( $self->{+PRECISION} ) + { + return 'ne' if $self->{+NEGATE}; + return 'eq'; + } + + return '!=' if $self->{+NEGATE}; + return '=='; +} + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + return 0 unless defined $got; + return 0 if ref $got; + return 0 unless length($got) && $got =~ m/\S/; + + my $input = $self->{+INPUT}; + my $negate = $self->{+NEGATE}; + my $tolerance = $self->{+TOLERANCE}; + my $precision = $self->{+PRECISION}; + + my @warnings; + my $out; + { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + + my $equal = ($input == $got); + if (!$equal) { + if (defined $tolerance) { + $equal = 1 if + $got > $input - $tolerance && + $got < $input + $tolerance; + } else { + $equal = + sprintf("%.*f", $precision, $got) eq + sprintf("%.*f", $precision, $input); + } + } + + $out = $negate ? !$equal : $equal; + } + + for my $warn (@warnings) { + if ($warn =~ m/numeric/) { + $out = 0; + next; # This warning won't help anyone. + } + warn $warn; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Float - Compare two values as numbers with tolerance. + +=head1 DESCRIPTION + +This is used to compare two numbers. You can also check that two numbers are not +the same. + +This is similar to Test2::Compare::Number, with extra checks to work around floating +point representation issues. + +The optional 'tolerance' parameter controls how close the two numbers must be to +be considered equal. Tolerance defaults to 1e-08. + +B: This will fail if the received value is undefined. It must be a number. + +B: This will fail if the comparison generates a non-numeric value warning +(which will not be shown). This is because it must get a number. The warning is +not shown as it will report to a useless line and filename. However, the test +diagnostics show both values. + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Andrew Grangaard Espazm@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Hash.pm b/cpan/Test2-Suite/lib/Test2/Compare/Hash.pm new file mode 100644 index 000000000000..409c55815672 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Hash.pm @@ -0,0 +1,238 @@ +package Test2::Compare::Hash; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/inref meta ending items order for_each_key for_each_val/; + +use Carp qw/croak confess/; +use Scalar::Util qw/reftype/; + +sub init { + my $self = shift; + + if( defined( my $ref = $self->{+INREF} ) ) { + croak "Cannot specify both 'inref' and 'items'" if $self->{+ITEMS}; + croak "Cannot specify both 'inref' and 'order'" if $self->{+ORDER}; + $self->{+ITEMS} = {%$ref}; + $self->{+ORDER} = [sort keys %$ref]; + } + else { + # Clone the ref to be safe + $self->{+ITEMS} = $self->{+ITEMS} ? {%{$self->{+ITEMS}}} : {}; + if ($self->{+ORDER}) { + my @all = keys %{$self->{+ITEMS}}; + my %have = map { $_ => 1 } @{$self->{+ORDER}}; + my @missing = grep { !$have{$_} } @all; + croak "Keys are missing from the 'order' array: " . join(', ', sort @missing) + if @missing; + } + else { + $self->{+ORDER} = [sort keys %{$self->{+ITEMS}}]; + } + } + + $self->{+FOR_EACH_KEY} ||= []; + $self->{+FOR_EACH_VAL} ||= []; + + $self->SUPER::init(); +} + +sub name { '' } + +sub meta_class { 'Test2::Compare::Meta' } + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + return 0 unless defined $got; + return 0 unless ref($got); + return 0 unless reftype($got) eq 'HASH'; + return 1; +} + +sub add_prop { + my $self = shift; + $self->{+META} = $self->meta_class->new unless defined $self->{+META}; + $self->{+META}->add_prop(@_); +} + +sub add_field { + my $self = shift; + my ($name, $check) = @_; + + croak "field name is required" + unless defined $name; + + croak "field '$name' has already been specified" + if exists $self->{+ITEMS}->{$name}; + + push @{$self->{+ORDER}} => $name; + $self->{+ITEMS}->{$name} = $check; +} + +sub add_for_each_key { + my $self = shift; + push @{$self->{+FOR_EACH_KEY}} => @_; +} + +sub add_for_each_val { + my $self = shift; + push @{$self->{+FOR_EACH_VAL}} => @_; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my @deltas; + my $items = $self->{+ITEMS}; + my $each_key = $self->{+FOR_EACH_KEY}; + my $each_val = $self->{+FOR_EACH_VAL}; + + # Make a copy that we can munge as needed. + my %fields = %$got; + + my $meta = $self->{+META}; + push @deltas => $meta->deltas(%params) if defined $meta; + + for my $key (@{$self->{+ORDER}}) { + my $check = $convert->($items->{$key}); + my $exists = exists $fields{$key}; + my $val = delete $fields{$key}; + + if ($exists) { + for my $kcheck (@$each_key) { + $kcheck = $convert->($kcheck); + + push @deltas => $kcheck->run( + id => [HASHKEY => $key], + convert => $convert, + seen => $seen, + exists => $exists, + got => $key, + ); + } + + for my $vcheck (@$each_val) { + $vcheck = $convert->($vcheck); + + push @deltas => $vcheck->run( + id => [HASH => $key], + convert => $convert, + seen => $seen, + exists => $exists, + got => $val, + ); + } + } + + push @deltas => $check->run( + id => [HASH => $key], + convert => $convert, + seen => $seen, + exists => $exists, + $exists ? (got => $val) : (), + ); + } + + if (keys %fields) { + for my $key (sort keys %fields) { + my $val = $fields{$key}; + + for my $kcheck (@$each_key) { + $kcheck = $convert->($kcheck); + + push @deltas => $kcheck->run( + id => [HASHKEY => $key], + convert => $convert, + seen => $seen, + got => $key, + exists => 1, + ); + } + + for my $vcheck (@$each_val) { + $vcheck = $convert->($vcheck); + + push @deltas => $vcheck->run( + id => [HASH => $key], + convert => $convert, + seen => $seen, + got => $val, + exists => 1, + ); + } + + # if items are left over, and ending is true, we have a problem! + if ($self->{+ENDING}) { + push @deltas => $self->delta_class->new( + dne => 'check', + verified => undef, + id => [HASH => $key], + got => $val, + check => undef, + + $self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (), + ); + } + } + } + + return @deltas; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Hash - Representation of a hash in a deep comparison. + +=head1 DESCRIPTION + +In deep comparisons this class is used to represent a hash. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Isa.pm b/cpan/Test2-Suite/lib/Test2/Compare/Isa.pm new file mode 100644 index 000000000000..337886ef0668 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Isa.pm @@ -0,0 +1,100 @@ +package Test2::Compare::Isa; +use strict; +use warnings; + +use Carp qw/confess/; +use Scalar::Util qw/blessed/; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/input/; + +# Overloads '!' for us. +use Test2::Compare::Negatable; + +sub init { + my $self = shift; + confess "input must be defined for 'Isa' check" + unless defined $self->{+INPUT}; + + $self->SUPER::init(@_); +} + +sub name { + my $self = shift; + my $in = $self->{+INPUT}; + return "$in"; +} + +sub operator { + my $self = shift; + return '!isa' if $self->{+NEGATE}; + return 'isa'; +} + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + + my $input = $self->{+INPUT}; + my $negate = $self->{+NEGATE}; + my $isa = blessed($got) && $got->isa($input); + + return !$isa if $negate; + return $isa; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Isa - Check if the value is an instance of the class. + +=head1 DESCRIPTION + +This is used to check if the got value is an instance of the expected class. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 TOYAMA Nao Enanto@moon.email.ne.jpE + +=back + +=head1 COPYRIGHT + +Copyright 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Meta.pm b/cpan/Test2-Suite/lib/Test2/Compare/Meta.pm new file mode 100644 index 000000000000..f12f59218dcf --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Meta.pm @@ -0,0 +1,183 @@ +package Test2::Compare::Meta; +use strict; +use warnings; + +use Test2::Compare::Delta(); +use Test2::Compare::Isa(); + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/items/; + +use Carp qw/croak confess/; +use Scalar::Util qw/reftype blessed/; + +sub init { + my $self = shift; + $self->{+ITEMS} ||= []; + $self->SUPER::init(); +} + +sub name { '' } + +sub verify { + my $self = shift; + my %params = @_; + return $params{exists} ? 1 : 0; +} + +sub add_prop { + my $self = shift; + my ($name, $check) = @_; + + croak "prop name is required" + unless defined $name; + + croak "check is required" + unless defined $check; + + my $meth = "get_prop_$name"; + croak "'$name' is not a known property" + unless $self->can($meth); + + if ($name eq 'isa') { + if (blessed($check) && $check->isa('Test2::Compare::Wildcard')) { + # Carry forward file and lines that are set in Test2::Tools::Compare::prop. + $check = Test2::Compare::Isa->new( + input => $check->expect, + file => $check->file, + lines => $check->lines, + ); + } else { + $check = Test2::Compare::Isa->new(input => $check); + } + } + + push @{$self->{+ITEMS}} => [$meth, $check, $name]; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my @deltas; + my $items = $self->{+ITEMS}; + + for my $set (@$items) { + my ($meth, $check, $name) = @$set; + + $check = $convert->($check); + + my $val = $self->$meth($got); + + push @deltas => $check->run( + id => [META => $name], + got => $val, + convert => $convert, + seen => $seen, + ); + } + + return @deltas; +} + +sub get_prop_blessed { blessed($_[1]) } + +sub get_prop_reftype { reftype($_[1]) } + +sub get_prop_isa { $_[1] } + +sub get_prop_this { $_[1] } + +sub get_prop_size { + my $self = shift; + my ($it) = @_; + + my $type = reftype($it) || ''; + + return scalar @$it if $type eq 'ARRAY'; + return scalar keys %$it if $type eq 'HASH'; + return undef; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Meta - Check library for meta-checks + +=head1 DESCRIPTION + +Sometimes in a deep comparison you want to run extra checks against an item +down the chain. This library allows you to write a check that verifies several +attributes of an item. + +=head1 DEFINED CHECKS + +=over 4 + +=item blessed + +Lets you check that an item is blessed, and that it is blessed into the +expected class. + +=item reftype + +Lets you check the reftype of the item. + +=item isa + +Lets you check if the item is an instance of the expected class. + +=item this + +Lets you check the item itself. + +=item size + +Lets you check the size of the item. For an arrayref this is the number of +elements. For a hashref this is the number of keys. For everything else this is +undef. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Negatable.pm b/cpan/Test2-Suite/lib/Test2/Compare/Negatable.pm new file mode 100644 index 000000000000..c2d50cca77bc --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Negatable.pm @@ -0,0 +1,121 @@ +package Test2::Compare::Negatable; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +require overload; +require Test2::Util::HashBase; + +sub import { + my ($pkg, $file, $line) = caller; + + my $sub = eval <<" EOT" or die $@; +package $pkg; +#line $line "$file" +sub { overload->import('!' => 'clone_negate', fallback => 1); Test2::Util::HashBase->import('negate')} + EOT + + $sub->(); + + no strict 'refs'; + *{"$pkg\::clone_negate"} = \&clone_negate; + *{"$pkg\::toggle_negate"} = \&toggle_negate; +} + +sub clone_negate { + my $self = shift; + my $clone = $self->clone; + $clone->toggle_negate; + return $clone; +} + +sub toggle_negate { + my $self = shift; + $self->set_negate($self->negate ? 0 : 1); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Negatable - Poor mans 'role' for compare objects that can be negated. + +=head1 DESCRIPTION + +Using this package inside an L subclass will overload +C and import C and C. + +=head1 WHY? + +Until perl 5.18 the 'fallback' parameter to L would not be inherited, +so we cannot use inheritance for the behavior we actually want. This module +works around the problem by emulating the C call we want for each +consumer class. + +=head1 ATTRIBUTES + +=over 4 + +=item $bool = $obj->negate + +=item $obj->set_negate($bool) + +=item $attr = NEGATE() + +The NEGATE attribute will be added via L. + +=back + +=head1 METHODS + +=over 4 + +=item $clone = $obj->clone_negate() + +Create a shallow copy of the object, and call C on it. + +=item $obj->toggle_negate() + +Toggle the negate attribute. If the attribute was on it will now be off, if it +was off it will now be on. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Number.pm b/cpan/Test2-Suite/lib/Test2/Compare/Number.pm new file mode 100644 index 000000000000..10d00328790f --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Number.pm @@ -0,0 +1,152 @@ +package Test2::Compare::Number; +use strict; +use warnings; + +use Carp qw/confess/; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/input mode/; + +# Overloads '!' for us. +use Test2::Compare::Negatable; + +sub init { + my $self = shift; + my $input = $self->{+INPUT}; + + confess "input must be defined for 'Number' check" + unless defined $input; + + # Check for '' + confess "input must be a number for 'Number' check" + unless length($input) && $input =~ m/\S/; + + defined $self->{+MODE} or $self->{+MODE} = '=='; + + $self->SUPER::init(@_); +} + +sub name { + my $self = shift; + my $in = $self->{+INPUT}; + return $in; +} + +my %NEGATED = ( + '==' => '!=', + '!=' => '==', + '<' => '>=', + '<=' => '>', + '>=' => '<', + '>' => '<=', +); + +sub operator { + my $self = shift; + return '' unless @_; + my ($got) = @_; + + return '' unless defined($got); + return '' unless length($got) && $got =~ m/\S/; + + return $NEGATED{ $self->{+MODE} } if $self->{+NEGATE}; + return $self->{+MODE}; +} + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + return 0 unless defined $got; + return 0 if ref $got; + return 0 unless length($got) && $got =~ m/\S/; + + my $want = $self->{+INPUT}; + my $mode = $self->{+MODE}; + my $negate = $self->{+NEGATE}; + + my @warnings; + my $out; + { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $out = $mode eq '==' ? ($got == $want) : + $mode eq '!=' ? ($got != $want) : + $mode eq '<' ? ($got < $want) : + $mode eq '<=' ? ($got <= $want) : + $mode eq '>=' ? ($got >= $want) : + $mode eq '>' ? ($got > $want) : + die "Unrecognised MODE"; + $out ^= 1 if $negate; + } + + for my $warn (@warnings) { + if ($warn =~ m/numeric/) { + $out = 0; + next; # This warning won't help anyone. + } + warn $warn; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Number - Compare two values as numbers + +=head1 DESCRIPTION + +This is used to compare two numbers. You can also check that two numbers are not +the same. + +B: This will fail if the received value is undefined. It must be a number. + +B: This will fail if the comparison generates a non-numeric value warning +(which will not be shown). This is because it must get a number. The warning is +not shown as it will report to a useless line and filename. However, the test +diagnostics show both values. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Object.pm b/cpan/Test2-Suite/lib/Test2/Compare/Object.pm new file mode 100644 index 000000000000..b0834122aa29 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Object.pm @@ -0,0 +1,256 @@ +package Test2::Compare::Object; +use strict; +use warnings; + +use Test2::Util qw/try/; + +use Test2::Compare::Meta(); + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/calls meta refcheck ending/; + +use Carp qw/croak confess/; +use Scalar::Util qw/reftype blessed/; + +sub init { + my $self = shift; + $self->{+CALLS} ||= []; + $self->SUPER::init(); +} + +sub name { '' } + +sub meta_class { 'Test2::Compare::Meta' } +sub object_base { 'UNIVERSAL' } + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + return 0 unless defined $got; + return 0 unless ref($got); + return 0 unless blessed($got); + return 0 unless $got->isa($self->object_base); + return 1; +} + +sub add_prop { + my $self = shift; + $self->{+META} = $self->meta_class->new unless defined $self->{+META}; + $self->{+META}->add_prop(@_); +} + +sub add_field { + my $self = shift; + $self->{+REFCHECK} = Test2::Compare::Hash->new unless defined $self->{+REFCHECK}; + + croak "Underlying reference does not have fields" + unless $self->{+REFCHECK}->can('add_field'); + + $self->{+REFCHECK}->add_field(@_); +} + +sub add_item { + my $self = shift; + $self->{+REFCHECK} = Test2::Compare::Array->new unless defined $self->{+REFCHECK}; + + croak "Underlying reference does not have items" + unless $self->{+REFCHECK}->can('add_item'); + + $self->{+REFCHECK}->add_item(@_); +} + +sub add_call { + my $self = shift; + my ($meth, $check, $name, $context) = @_; + $name ||= ref $meth eq 'ARRAY' ? $meth->[0] + : ref $meth eq 'CODE' ? '\&CODE' + : $meth; + push @{$self->{+CALLS}} => [$meth, $check, $name, $context || 'scalar']; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my @deltas; + my $meta = $self->{+META}; + my $refcheck = $self->{+REFCHECK}; + + push @deltas => $meta->deltas(%params) if defined $meta; + + for my $call (@{$self->{+CALLS}}) { + my ($meth, $check, $name, $context)= @$call; + $context ||= 'scalar'; + + $check = $convert->($check); + + my @args; + if (ref($meth) eq 'ARRAY') { + ($meth,@args) = @{$meth}; + } + + my $exists = ref($meth) || $got->can($meth); + my $val; + my ($ok, $err) = try { + $val = $exists + ? ( $context eq 'list' ? [ $got->$meth(@args) ] : + $context eq 'hash' ? { $got->$meth(@args) } : + $got->$meth(@args) + ) + : undef; + }; + + if (!$ok) { + push @deltas => $self->delta_class->new( + verified => undef, + id => [METHOD => $name], + got => undef, + check => $check, + exception => $err, + ); + } + else { + push @deltas => $check->run( + id => [METHOD => $name], + convert => $convert, + seen => $seen, + exists => $exists, + $exists ? (got => $val) : (), + ); + } + } + + return @deltas unless defined $refcheck; + + $refcheck->set_ending($self->{+ENDING}); + + if ($refcheck->verify(%params)) { + push @deltas => $refcheck->deltas(%params); + } + else { + push @deltas => $self->delta_class->new( + verified => undef, + id => [META => 'Object Ref'], + got => $got, + check => $refcheck, + ); + } + + return @deltas; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Object - Representation of an object during deep +comparison. + +=head1 DESCRIPTION + +This class lets you specify an expected object in a deep comparison. You can +check the fields/elements of the underlying reference, call methods to verify +results, and do meta checks for object type and ref type. + +=head1 METHODS + +=over 4 + +=item $class = $obj->meta_class + +The meta-class to be used when checking the object type. This is mainly listed +because it is useful to override for specialized object subclasses. + +This normally just returns L. + +=item $class = $obj->object_base + +The base-class to be expected when checking the object type. This is mainly +listed because it is useful to override for specialized object subclasses. + +This normally just returns 'UNIVERSAL'. + +=item $obj->add_prop(...) + +Add a meta-property to check, see L. This method +just delegates. + +=item $obj->add_field(...) + +Add a hash-field to check, see L. This method +just delegates. + +=item $obj->add_item(...) + +Add an array item to check, see L. This method +just delegates. + +=item $obj->add_call($method, $check) + +=item $obj->add_call($method, $check, $name) + +=item $obj->add_call($method, $check, $name, $context) + +Add a method call check. This will call the specified method on your object and +verify the result. C<$method> may be a method name, an array ref, or a coderef. + +If it's an arrayref, the first element must be the method name, and +the rest are arguments that will be passed to it. + +In the case of a coderef it can be helpful to provide an alternate +name. When no name is provided the name is either C<$method> or the +string '\&CODE'. + +If C<$context> is C<'list'>, the method will be invoked in list +context, and the result will be an arrayref. + +If C<$context> is C<'hash'>, the method will be invoked in list +context, and the result will be a hashref (this will warn if the +method returns an odd number of values). + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/OrderedSubset.pm b/cpan/Test2-Suite/lib/Test2/Compare/OrderedSubset.pm new file mode 100644 index 000000000000..423bfe80a522 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/OrderedSubset.pm @@ -0,0 +1,175 @@ +package Test2::Compare::OrderedSubset; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/inref items/; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +sub init { + my $self = shift; + + if(my $ref = $self->{+INREF}) { + croak "Cannot specify both 'inref' and 'items'" if $self->{+ITEMS}; + croak "'inref' must be an array reference, got '$ref'" unless reftype($ref) eq 'ARRAY'; + $self->{+ITEMS} = [@{$self->{+INREF}}]; + } + + $self->{+ITEMS} ||= []; + + $self->SUPER::init(); +} + +sub name { '' } + +sub verify { + my $self = shift; + my %params = @_; + + return 0 unless $params{exists}; + defined( my $got = $params{got} ) || return 0; + return 0 unless ref($got); + return 0 unless reftype($got) eq 'ARRAY'; + return 1; +} + +sub add_item { + my $self = shift; + my $check = pop; + + push @{$self->{+ITEMS}} => $check; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my @deltas; + my $state = 0; + my $items = $self->{+ITEMS}; + + my $idx = 0; + + for my $item (@$items) { + my $check = $convert->($item); + + my $i = $idx; + my $found; + while($i < @$got) { + my $val = $got->[$i++]; + next if $check->run( + id => [ARRAY => $i], + convert => $convert, + seen => $seen, + exists => 1, + got => $val, + ); + + $idx = $i; + $found++; + last; + } + + next if $found; + + push @deltas => Test2::Compare::Delta->new( + verified => 0, + id => ['ARRAY', '?'], + check => $check, + dne => 'got', + ); + } + + return @deltas; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::OrderedSubset - Internal representation of an ordered subset. + +=head1 DESCRIPTION + +This module is used to ensure an array has all the expected items int he +expected order. It ignores any unexpected items mixed into the array. It only +cares that all the expected values are present, and in order, everything else +is noise. + +=head1 METHODS + +=over 4 + +=item $ref = $arr->inref() + +If the instance was constructed from an actual array, this will have the +reference to that array. + +=item $arrayref = $arr->items() + +=item $arr->set_items($arrayref) + +All the expected items, in order. + +=item $name = $arr->name() + +Always returns the string C<< "" >>. + +=item $bool = $arr->verify(got => $got, exists => $bool) + +Check if C<$got> is an array reference or not. + +=item $arr->add_item($item) + +Add an item to the list of values to check. + +=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen) + +Find the differences between the expected array values and those in the C<$got> +arrayref. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Pattern.pm b/cpan/Test2-Suite/lib/Test2/Compare/Pattern.pm new file mode 100644 index 000000000000..93e33f5321f4 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Pattern.pm @@ -0,0 +1,93 @@ +package Test2::Compare::Pattern; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/pattern stringify_got/; + +# Overloads '!' for us. +use Test2::Compare::Negatable; + +use Carp qw/croak/; + +sub init { + my $self = shift; + + croak "'pattern' is a required attribute" unless $self->{+PATTERN}; + + $self->{+STRINGIFY_GOT} ||= 0; + + $self->SUPER::init(); +} + +sub name { shift->{+PATTERN} . "" } +sub operator { shift->{+NEGATE} ? '!~' : '=~' } + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + return 0 unless defined($got); + return 0 if ref $got && !$self->stringify_got; + + return $got !~ $self->{+PATTERN} + if $self->{+NEGATE}; + + return $got =~ $self->{+PATTERN}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Pattern - Use a pattern to validate values in a deep +comparison. + +=head1 DESCRIPTION + +This allows you to use a regex to validate a value in a deep comparison. +Sometimes a value just needs to look right, it may not need to be exact. An +example is a memory address that might change from run to run. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Ref.pm b/cpan/Test2-Suite/lib/Test2/Compare/Ref.pm new file mode 100644 index 000000000000..bd22814f473f --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Ref.pm @@ -0,0 +1,109 @@ +package Test2::Compare::Ref; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/input/; + +use Test2::Util::Ref qw/render_ref rtype/; +use Scalar::Util qw/refaddr/; +use Carp qw/croak/; + +sub init { + my $self = shift; + + croak "'input' is a required attribute" + unless $self->{+INPUT}; + + croak "'input' must be a reference, got '" . $self->{+INPUT} . "'" + unless ref $self->{+INPUT}; + + $self->SUPER::init(); +} + +sub operator { '==' } + +sub name { render_ref($_[0]->{+INPUT}) } + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + + my $in = $self->{+INPUT}; + return 0 unless ref $in; + return 0 unless ref $got; + + my $in_type = rtype($in); + my $got_type = rtype($got); + + return 0 unless $in_type eq $got_type; + + # Don't let overloading mess with us. + return refaddr($in) == refaddr($got); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Ref - Ref comparison + +=head1 DESCRIPTION + +Used to compare two refs in a deep comparison. + +=head1 SYNOPSIS + + my $ref = {}; + my $check = Test2::Compare::Ref->new(input => $ref); + + # Passes + is( [$ref], [$check], "The array contains the exact ref we want" ); + + # Fails, they both may be empty hashes, but we are looking for a specific + # reference. + is( [{}], [$check], "This will fail"); + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Regex.pm b/cpan/Test2-Suite/lib/Test2/Compare/Regex.pm new file mode 100644 index 000000000000..bed09dfbb25d --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Regex.pm @@ -0,0 +1,93 @@ +package Test2::Compare::Regex; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/input/; + +use Test2::Util::Ref qw/render_ref rtype/; +use Carp qw/croak/; + +sub init { + my $self = shift; + + croak "'input' is a required attribute" + unless $self->{+INPUT}; + + croak "'input' must be a regex , got '" . $self->{+INPUT} . "'" + unless rtype($self->{+INPUT}) eq 'REGEXP'; + + $self->SUPER::init(); +} + +sub stringify_got { 1 } + +sub operator { 'eq' } + +sub name { "" . $_[0]->{+INPUT} } + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + + my $in = $self->{+INPUT}; + my $got_type = rtype($got) or return 0; + + return 0 unless $got_type eq 'REGEXP'; + + return "$in" eq "$got"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Regex - Regex direct comparison + +=head1 DESCRIPTION + +Used to compare two regexes. This compares the stringified form of each regex. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Scalar.pm b/cpan/Test2-Suite/lib/Test2/Compare/Scalar.pm new file mode 100644 index 000000000000..a97269705bf8 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Scalar.pm @@ -0,0 +1,111 @@ +package Test2::Compare::Scalar; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/item/; + +use Carp qw/croak confess/; +use Scalar::Util qw/reftype blessed/; + +sub init { + my $self = shift; + croak "'item' is a required attribute" + unless defined $self->{+ITEM}; + + $self->SUPER::init(); +} + +sub name { '' } +sub operator { '${...}' } + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + return 0 unless defined $got; + return 0 unless ref($got); + return 0 unless reftype($got) eq 'SCALAR' || reftype($got) eq 'VSTRING'; + return 1; +} + +sub deltas { + my $self = shift; + my %params = @_; + my ($got, $convert, $seen) = @params{qw/got convert seen/}; + + my $item = $self->{+ITEM}; + my $check = $convert->($item); + + return ( + $check->run( + id => ['SCALAR' => '$*'], + got => $$got, + convert => $convert, + seen => $seen, + exists => 1, + ), + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Scalar - Representation of a Scalar Ref in deep +comparisons + +=head1 DESCRIPTION + +This is used in deep comparisons to represent a scalar reference. + +=head1 SYNOPSIS + + my $sr = Test2::Compare::Scalar->new(item => 'foo'); + + is([\'foo'], $sr, "pass"); + is([\'bar'], $sr, "fail, different value"); + is(['foo'], $sr, "fail, not a ref"); + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Set.pm b/cpan/Test2-Suite/lib/Test2/Compare/Set.pm new file mode 100644 index 000000000000..74203c12b7be --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Set.pm @@ -0,0 +1,153 @@ +package Test2::Compare::Set; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/checks _reduction/; + +use Test2::Compare::Delta(); + +use Carp qw/croak confess/; +use Scalar::Util qw/reftype/; + +sub init { + my $self = shift; + + my $reduction = delete $self->{reduction} || 'any'; + + $self->{+CHECKS} ||= []; + + $self->set_reduction($reduction); + + $self->SUPER::init(); +} + +sub name { '' } +sub operator { $_[0]->{+_REDUCTION} } +sub reduction { $_[0]->{+_REDUCTION} } + +my %VALID = (any => 1, all => 1, none => 1); +sub set_reduction { + my $self = shift; + my ($redu) = @_; + + croak "'$redu' is not a valid set reduction" + unless $VALID{$redu}; + + $self->{+_REDUCTION} = $redu; +} + +sub verify { + my $self = shift; + my %params = @_; + return 1; +} + +sub add_check { + my $self = shift; + push @{$self->{+CHECKS}} => @_; +} + +sub deltas { + my $self = shift; + my %params = @_; + + my $checks = $self->{+CHECKS}; + my $reduction = $self->{+_REDUCTION}; + my $convert = $params{convert}; + + unless ($checks && @$checks) { + my $file = $self->file; + my $lines = $self->lines; + + my $extra = ""; + if ($file and $lines and @$lines) { + my $lns = (@$lines > 1 ? 'lines ' : 'line ' ) . join ', ', @$lines; + $extra = " (Set defined in $file $lns)"; + } + + die "No checks defined for set$extra\n"; + } + + my @deltas; + my $i = 0; + for my $check (@$checks) { + my $c = $convert->($check); + my $id = [META => "Check " . $i++]; + my @d = $c->run(%params, id => $id); + + if ($reduction eq 'any') { + return () unless @d; + push @deltas => @d; + } + elsif ($reduction eq 'all') { + push @deltas => @d; + } + elsif ($reduction eq 'none') { + push @deltas => Test2::Compare::Delta->new( + verified => 0, + id => $id, + got => $params{got}, + check => $c, + ) unless @d; + } + else { + die "Invalid reduction: $reduction\n"; + } + } + + return @deltas; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Set - Allows a field to be matched against a set of +checks. + +=head1 DESCRIPTION + +This module is used by the C function in the +L plugin. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/String.pm b/cpan/Test2-Suite/lib/Test2/Compare/String.pm new file mode 100644 index 000000000000..8d33aba3706a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/String.pm @@ -0,0 +1,108 @@ +package Test2::Compare::String; +use strict; +use warnings; + +use Carp qw/confess/; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/input/; + +# Overloads '!' for us. +use Test2::Compare::Negatable; + +sub stringify_got { 1 } + +sub init { + my $self = shift; + confess "input must be defined for 'String' check" + unless defined $self->{+INPUT}; + + $self->SUPER::init(@_); +} + +sub name { + my $self = shift; + my $in = $self->{+INPUT}; + return "$in"; +} + +sub operator { + my $self = shift; + + return '' unless @_; + my ($got) = @_; + + return '' unless defined($got); + + return 'ne' if $self->{+NEGATE}; + return 'eq'; +} + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + return 0 unless defined $got; + + my $input = $self->{+INPUT}; + my $negate = $self->{+NEGATE}; + + return "$input" ne "$got" if $negate; + return "$input" eq "$got"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::String - Compare two values as strings + +=head1 DESCRIPTION + +This is used to compare two items after they are stringified. You can also check +that two strings are not equal. + +B: This will fail if the received value is undefined, it must be defined. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Undef.pm b/cpan/Test2-Suite/lib/Test2/Compare/Undef.pm new file mode 100644 index 000000000000..0c06f4ce47c3 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Undef.pm @@ -0,0 +1,83 @@ +package Test2::Compare::Undef; +use strict; +use warnings; + +use Carp qw/confess/; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase; + +# Overloads '!' for us. +use Test2::Compare::Negatable; + +sub name { '' } + +sub operator { + my $self = shift; + + return 'IS NOT' if $self->{+NEGATE}; + return 'IS'; +} + +sub verify { + my $self = shift; + my %params = @_; + my ($got, $exists) = @params{qw/got exists/}; + + return 0 unless $exists; + + return !defined($got) unless $self->{+NEGATE}; + return defined($got); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Undef - Check that something is undefined + +=head1 DESCRIPTION + +Make sure something is undefined in a comparison. You can also check that +something is defined. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Compare/Wildcard.pm b/cpan/Test2-Suite/lib/Test2/Compare/Wildcard.pm new file mode 100644 index 000000000000..67cf91e79402 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Compare/Wildcard.pm @@ -0,0 +1,69 @@ +package Test2::Compare::Wildcard; +use strict; +use warnings; + +use base 'Test2::Compare::Base'; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/expect/; + +use Carp qw/croak/; + +sub init { + my $self = shift; + croak "'expect' is a require attribute" + unless exists $self->{+EXPECT}; + + $self->SUPER::init(); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Compare::Wildcard - Placeholder check. + +=head1 DESCRIPTION + +This module is used as a temporary placeholder for values that still need to be +converted. This is necessary to carry forward the filename and line number which +would be lost in the conversion otherwise. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual.pm b/cpan/Test2-Suite/lib/Test2/Manual.pm new file mode 100644 index 000000000000..3e58d3af78b7 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual.pm @@ -0,0 +1,80 @@ +package Test2::Manual; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual - Documentation hub for Test2 and Test2-Suite. + +=head1 DESCRIPTION + +This is the hub for L and L documentation. + +=head1 WRITING TESTS + +The L POD is the hub for documentation related to +writing tests. + +=head1 WRITING TOOLS + +The L POD is the hub for documentation related to +writing new tools. + +=head1 GUTS AND INNER WORKINGS + +The L POD is the hub for documentation of the inner +workings of Test2 components. + +=head1 A NOTE ON CONCURRENCY (SUPPORT FOR FORKING AND THREADING) + +The L POD documents the concurrency support policy +for L. + +=head1 CONTRIBUTING + +The L POD is for people who want to contribute to +L or L directly. + +=head1 SEE ALSO + +L - Test2 itself. + +L - Initial tools built using L. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy.pm new file mode 100644 index 000000000000..84eed6e71571 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy.pm @@ -0,0 +1,88 @@ +package Test2::Manual::Anatomy; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Anatomy - The hub for documentation of the inner workings of +Test2 components. + +=head1 DESCRIPTION + +This section covers internals of the Test2 architecture. This is useful +information for toolbuilder, but is essential information for maintainers of +Test2 itself. + +=head1 END TO END + +The L document is an overview of Test2 from load to finish. + +=head1 EVENTS + +The L document explains the internals of events. + +=head1 THE CONTEXT + +The L document explains how the +L object works. + +=head1 THE API AND THE API INSTANCE + +The L document explains the inner workings of the +Test2 API. + +=head1 HUBS + +The L document explains the inner working of +the Test2 hub stack, and the hubs therein. + +=head1 THE IPC SYSTEM + +The L document describes the IPC system. + +=head1 INTERNAL UTILITIES + +The L document describes various utilities +provided by the Test2 system. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/API.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/API.pm new file mode 100644 index 000000000000..e220be4b422c --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/API.pm @@ -0,0 +1,78 @@ +package Test2::Manual::Anatomy::API; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Anatomy::API - Internals documentation for the API. + +=head1 DESCRIPTION + +This document covers some of the internals of L. + +=head1 IMPLEMENTATION DETAILS + +=head2 Test2::API + +L provides a functional interface to any test2 global state. This +API should be preserved regardless of internal details of how and where the +global state is stored. + +This module itself does not store any state (with a few minor exceptions) but +instead relies on L to store state. This module is really +intended to be the layer between the consumer and the implementation details. +Ideally the implementation details can change any way they like, and this +module can be updated to use the new details without breaking anything. + +=head2 Test2::API::Instance + +L is where the global state is actually managed. This is +an implementation detail, and should not be relied upon. It is entirely +possible that L could be removed completely, or changed +in incompatible ways. Really these details are free to change so long as +L is not broken. + +L is fairly well documented, so no additionally +documentation is needed for this manual page. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Context.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Context.pm new file mode 100644 index 000000000000..0ccf46caa17d --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Context.pm @@ -0,0 +1,114 @@ +package Test2::Manual::Anatomy::Context; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Anatomy::Context - Internals documentation for the Context +objects. + +=head1 DESCRIPTION + +This document explains how the L object works. + +=head1 WHAT IS THE CONTEXT OBJECT? + +The context object is one of the key components of Test2, and makes many +features possible that would otherwise be impossible. Every test tool starts by +getting a context, and ends by releasing the context. A test tool does all its +work between getting and releasing the context. The context instance is the +primary interface for sending events to the Test2 stack. Finally the context +system is responsible for tracking what file and line number a tool operates +on, which is critical for debugging. + +=head2 PRIMARY INTERFACE FOR TEST TOOLS + +Nearly every Test2 based tool should start by calling C<$ctx = +Test2::API::context()> in order to get a context object, and should end by +calling C<< $ctx->release() >>. Once a tool has its context object it can call +methods on the object to send events or have other effects. Nearly everything a +test tool needs to do should be done through the context object. + +=head2 TRACK FILE AND LINE NUMBERS FOR ERROR REPORTING + +When you call C a new context object will be returned. If +there is already a context object in effect (from a different point in the +stack) you will get a clone of the existing one. If there is not already a +current context then a completely new one will be generated. When a new context +is generated Test2 will determine the file name and line number for your test +code, these will be used when reporting any failures. + +Typically the file and line number will be determined using C to look +at your tools caller. The C<$Test::Builder::Level> will be respected if +detected, but is discouraged in favor of just using context objects at every +level. + +When calling C you can specify the +C<< level => $count >> arguments if you need to look at a deeper caller. + +=head2 PRESERVE $?, $!, $^E AND $@ + +When you call C the current values of C<$?>, C<$!>, +C<$^E>, and C<$@> are stored in the context object itself. Whenever the context +is released the original values of these variables will be restored. This +protects the variables from any side effects caused by testing tools. + +=head2 FINALIZE THE API STATE + +L works via a hidden singleton instance of L. +The singleton has some state that is not set in stone until the last possible +minute. The last possible minute happens to be the first time a context is +acquired. State includes IPC instance, Formatter class, Root PID, etc. + +=head2 FIND/CREATE THE CURRENT/ROOT HUB + +L has a stack of hubs, the stack can be accessed via +L. When you get a context it will find the current +hub, if there is no current hub then the root one will be initialized. + +=head2 PROVIDE HOOKS + +There are hooks that run when contexts are created, found, and released. See +L for details on these hooks and how to use them. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/EndToEnd.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/EndToEnd.pm new file mode 100644 index 000000000000..2bd1a39ae008 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/EndToEnd.pm @@ -0,0 +1,376 @@ +package Test2::Manual::Anatomy::EndToEnd; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::EndToEnd - Overview of Test2 from load to finish. + +=head1 DESCRIPTION + +This is a high level overview of everything from loading Test2 through the end +of a test script. + +=head1 WHAT HAPPENS WHEN I LOAD THE API? + + use Test2::API qw/context/; + +=over 4 + +=item A singleton instance of Test2::API::Instance is created. + +You have no access to this, it is an implementation detail. + +=item Several API functions are defined that use the singleton instance. + +You can import these functions, or use them directly. + +=item Then what? + +It waits... + +The API intentionally does as little as possible. At this point something can +still change the formatter, load L, or have other global effects +that need to be done before the first L is created. Once +the first L is created the API will finish initialization. + +See L for more information. + +=back + +=head1 WHAT HAPPENS WHEN I USE A TOOL? + +This section covers the basic workflow all tools such as C must follow. + + sub ok($$) { + my ($bool, $name) = @_; + + my $ctx = context(); + + my $event = $ctx->send_event('Ok', pass => $bool, name => $name); + + ... + + $ctx->release; + return $bool; + } + + ok(1, "1 is true"); + +=over 4 + +=item A tool function is run. + + ok(1, "1 is true"); + +=item The tool acquires a context object. + + my $ctx = context(); + +See L for more information. + +=item The tool uses the context object to create, send, and return events. + +See L for more information. + + my $event = $ctx->send_event('Ok', pass => $bool, name => $name); + +=item When done the tool MUST release the context. + +See L for more information. + + $ctx->release(); + +=item The tool returns. + + return $bool; + +=back + +=head1 WHAT HAPPENS WHEN I ACQUIRE A CONTEXT? + + my $ctx = context(); + +These actions may not happen exactly in this order, but that is an +implementation detail. For the purposes of this document this order is used to +help the reader understand the flow. + +=over 4 + +=item $!, $@, $? and $^E are captured and preserved. + +Test2 makes a point to preserve the values of $!, $@, $? and $^E such that the test +tools do not modify these variables unexpectedly. They are captured first thing +so that they can be restored later. + +=item The API state is changed to 'loaded'. + +The 'loaded' state means that test tools have already started running. This is +important as some plugins need to take effect before any tests are run. This +state change only happens the first time a context is acquired, and may trigger +some hooks defined by plugins to run. + +=item The current hub is found. + +A context attaches itself to the current L. If there is no current +hub then the root hub will be initialized. This will also initialize the hub +stack if necessary. + +=item Context acquire hooks fire. + +It is possible to create global, or hub-specific hooks that fire whenever a +context is acquired, these hooks will fire now. These hooks fire even if there +is an existing context. + +=item Any existing context is found. + +If the current hub already has a context then a clone of it will be used +instead of a completely new context. This is important because it allows nested +tools to inherit the context used by parent tools. + +=item Stack depth is measured. + +Test2 makes a point to catch mistakes in how the context is used. The stack +depth is used to accomplish this. If there is an existing context the depth +will be checked against the one found here. If the old context has the same +stack depth, or a shallower one, it means a tool is misbehaving and did not +clean up the context when it was done, in which case the old context will be +cleaned up, and a warning issued. + +=item A new context is created (if no existing context was found) + +If there is no existing context, a new one will be created using the data +collected so far. + +=item Context init hooks fire (if no existing context was found) + +If a new context was created, context-creation hooks will fire. + +=item $!, $@, $?, and $^E are restored. + +We make sure $!, $@, $?, and $^E are unchanged at this point so that changes we +made will not effect anything else. This is done in case something inside the +context construction accidentally changed these vars. + +=item The context is returned. + +You have a shiney new context object, or a clone of the existing context. + +=back + +=head1 WHAT HAPPENS WHEN I SEND AN EVENT? + + my $event = $ctx->send_event('Ok', pass => $bool, name => $name); + +=over 4 + +=item The Test2::Event::Ok module is loaded. + +The C method will automatically load any Event package necessary. +Normally C will assume the first argument is an event class +without the C prefix, which it will add for you. If you want to +use an event class that is in a different namespace you can prefix the class +name with a C<+> to tell the tool that you are giving a fully qualified class +name: + + my $event = $ctx->send_event('+Fully::Qualified::Event', pass => $bool, name => $name); + +=item A new instance of Test2::Event::Ok is created. + +The event object is instantiated using the provided parameters. + +=item The event object is sent to the hub. + +The hub takes over from here. + +=item The hub runs the event through any filters. + +Filters are able to modify or remove events. Filters are run first, before the +event can modify global test state. + +=item The global test state is updated to reflect the event. + +If the event effects test count then the count will be incremented. If the +event causes failure then the failure count will be incremented. There are a +couple other ways the global state can be effected as well. + +=item The event is sent to the formatter + +After the state is changed the hub will send the event to the formatter for +rendering. This is where TAP is normally produced. + +=item The event is sent to all listeners. + +There can be any number of listeners that take action when events are +processed, this happens now. + +=back + +=head1 WHAT HAPPENS WHEN I RELEASE A CONTEXT? + + $ctx->release; + +=over 4 + +=item The current context clone is released. + +If your tool is nested inside another, then releasing will simply destroy the +copy of the context, nothing else will happen. + +=item If this was the canonical context, it will actually release + +When a context is created it is considered 'canon'. Any context obtained by a +nested tool will be considered a child context linked to the canonical one. +Releasing child contexts does not do anything of note (but is still required). + +=item Release hooks are called + +Release hooks are the main motivation behind making the C method, +and making it a required action on the part of test tools. These are hooks that +we can have called when a tool is complete. This is how plugins like +L are implemented. If we simply had a destructor call +the hooks then we would be unable to write this plugin as a C inside of a +destructor is useless. + +=item The context is cleared + +The main context data is cleared allowing the next tool to create a new +context. This is important as the next tool very likely has a new line number. + +=item $!, $@, $?, and $^E are restored + +When a Test2 tool is complete it will restore $@, $!, $? and $^E to avoid action at +a distance. + +=back + +=head1 WHAT HAPPENS WHEN I USE done_testing()? + + done_testing(); + +=over 4 + +=item Any pending IPC events will be culled. + +If IPC is turned on, a final culling will take place. + +=item Follow-up hooks are run + +The follow-up hooks are a way to run actions when a hub is complete. This is +useful for adding cleanup tasks, or final tests to the end of a test. + +=item The final plan event is generated and processed. + +The final plan event will be produced using the current test count as the +number of tests planned. + +=item The current hub is finalized. + +This will mark the hub is complete, and will not allow new events to be +processed. + +=back + +=head1 WHAT HAPPENS WHEN A TEST SCRIPT IS DONE? + +Test2 has some behaviors it runs in an C block after tests are +done running. This end block does some final checks to warn you if something +went wrong. This end block also sets the exit value of the script. + +=over 4 + +=item API Versions are checked. + +A warning will be produced if L is loaded, but has a different +version compared to L. This situation can happen if you downgrade +to an older Test-Simple distribution, and is a bad situation. + +=item Any remaining context objects are cleaned up. + +If there are leftover context objects they will need to be cleaned up. A +leftover context is never a good thing, and usually requires a warning. A +leftover context could also be the result of an exception being thrown which +terminates the script, L is fairly good at noticing this and not warning +in these cases as the warning would simply be noise. + +=item Child processes are sent a 'waiting' event. + +If IPC is active, a waiting event is sent to all child processes. + +=item The script will wait for all child processes and/or threads to complete. + +This happens only when IPC is loaded, but Test::Builder is not. This behavior +is useful, but would break compatibility for legacy tests. + +=item The hub stack is cleaned up. + +All hubs are finalized starting from the top. Leftover hubs are usually a bad +thing, so a warning is produced if any are found. + +=item The root hub is finalized. + +This step is a no-op if C was used. If needed this will mark +the root hub as finished. + +=item Exit callbacks are called. + +This is a chance for plugins to modify the final exit value of the script. + +=item The scripts exit value ($?) is set. + +If the test encountered any failures this will be set to a non-zero value. If +possible this will be set to the number of failures, or 255 if the number is +larger than 255 (the max value allowed). + +=item Broken module diagnostics + +Test2 is aware of many modules which were broken by Test2's release. At this +point the script will check if any known-broken modules were loaded, and warn +you if they were. + +B This only happens if there were test failures. No broken module +warnings are produced on a success. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Event.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Event.pm new file mode 100644 index 000000000000..a1f41220cdcf --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Event.pm @@ -0,0 +1,410 @@ +package Test2::Manual::Anatomy::Event; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Anatomy::Event - The internals of events + +=head1 DESCRIPTION + +Events are how tools effect global state, and pass information along to the +harness, or the human running the tests. + +=head1 HISTORY + +Before proceeding it is important that you know some history of events. +Initially there was an event API, and an event would implement the API to +produce an effect. This API proved to be lossy and inflexible. Recently the +'facet' system was introduced, and makes up for the shortcoming and +inflexibility of the old API. + +All events must still implement the old API, but that can be largely automated +if you use the facet system effectively. Likewise essential facets can often be +deduced from events that only implement the old API, though their information +maybe less complete. + +=head1 THE EVENT OBJECT + +All event objects must subclass L. If you inherit from this base +class, and implement the old API properly, facets will be generated for you for +free. On the other hand you can inherit from this, and also import +L which will instead rely on your facet data, and +deduce the old API from them. + +All new events C implement both APIs one way or the other. A common way +to do this is to simply implement both APIs directly in your event. + +Here is a good template for a new event: + + package Test2::Event::Mine; + use strict; + use warnings; + + use parent 'Test2::Event'; + use Test2::Util::Facets2Legacy ':ALL'; + + sub facet_data { + my $self = shift; + + # Adds 'about', 'amnesty', and 'trace' facets + my $out = $self->common_facet_data; + + # Add any additional facets to the $out hashref + ... + + return $out; + } + + 1; + +=head1 THE FACET API + +The new API is a single method: C. This method must return a +hashref where each key is specific to a facet type, and the value is either a +facet hashref, or an array of hashrefs. Some facets C be lone hashrefs, +others C be hashrefs inside an arrayref. + +The I facet types are as follows: + +=over 4 + +=item assert => {details => $name, pass => $bool, no_debug => $bool, number => $maybe_int} + +Documented in L. An event may only have one. + +The 'details' key is the name of the assertion. + +The 'pass' key denotes a passing or failing assertion. + +The 'no_debug' key tells any harness or formatter that diagnostics should not +be added automatically to a failing assertion (used when there are custom +diagnostics instead). + +The 'number' key is for harness use, never set it yourself. + +=item about => {details => $string, no_display => $bool, package => $pkg} + +Documented in L. An event may only have one. + +'details' is a human readable string describing the overall event. + +'no_display' means that a formatter/harness should hide the event. + +'package' is the package of the event the facet describes (IE: L) + +=item amnesty => [{details => $string, tag => $short_string, inherited => $bool}] + +Documented in L. An event may have multiple. + +This event is how things like 'todo' are implemented. Amnesty prevents a +failing assertion from causing a global test failure. + +'details' is a human readable description of why the failure is being granted +amnesty (IE The 'todo' reason) + +'tag' is a short human readable string, or category for the amnesty. This is +typically 'TODO' or 'SKIP'. + +'inherited' is true if the amnesty was applied in a parent context (true if +this test is run in a subtest that is marked todo). + +=item control => {details => $string, global => $bool, terminate => $maybe_int, halt => $bool, has_callback => $bool, encoding => $enc} + +Documented in L. An event may have one. + +This facet is used to apply extra behavior when the event is processed. + +'details' is a human readable explanation for the behavior. + +'global' true if this event should be forwarded to, and processed by, all hubs +everywhere. (bail-out uses this) + +'terminate' this should either be undef, or an integer. When defined this will +cause the test to exit with the specific exit code. + +'halt' is used to signal any harness that no further test files should be run +(bail-out uses this). + +'has_callback' is set to true if the event has a callback sub defined. + +'encoding' used to tell the formatter what encoding to use. + +=item errors => [{details => $string, tag => $short_string, fail => $bool}] + +Documented in L. An event may have multiple. + +'details' is a human readable explanation of the error. + +'tag' is a short human readable category for the error. + +'fail' is true if the error should cause test failure. If this is false the +error is simply informative, but not fatal. + +=item info => [{details => $string, tag => $short_string, debug => $bool, important => $bool}] + +Documented in L. An event may have multiple. + +This is how diag and note are implemented. + +'details' human readable message. + +'tag' short category for the message, such as 'diag' or 'note'. + +'debug' is true if the message is diagnostics in nature, this is the main +difference between a note and a diag. + +'important' is true if the message is not diagnostics, but is important to have +it shown anyway. This is primarily used to communicate with a harness. + +=item parent => {details => $string, hid => $hid, children => [...], buffered => 1} + +Documented in L. An event may have one. + +This is used by subtests. + +'details' human readable name of the subtest. + +'hid' subtest hub id. + +'children' an arrayref containing facet_data instances from all child events. + +'buffered' true if it was a buffered subtest. + +=item plan => {details => $string, count => $int, skip => $bool, none => $bool} + +Documented in L. An event may have one. + +'details' is a human readable string describing the plan (for instance, why a +test is skipped) + +'count' is the number of expected assertions (0 for skip) + +'skip' is true if the plan is to skip the test. + +'none' used for Test::More's 'no_plan' plan. + +=item trace => {details => $string, frame => [$pkg, $file, $line, $sub], pid => $int, tid => $int, cid => $cid, hid => $hid, nested => $int, buffered => $bool} + +Documented in L. An event may have one. + +This is how debugging information is tracked. This is taken from the context +object at event creation. + +'details' human readable debug message (otherwise generated from frame) + +'frame' first 4 fields returned by caller: +C<[$package, $file, $line, $subname]>. + +'pid' the process id in which the event was created. + +'tid' the thread is in which the event was created. + +'cid' the id of the context used to create the event. + +'hid' the id of the hub to which the event was sent. + +'nest' subtest nesting depth of the event. + +'buffered' is true if the event was generated inside a buffered subtest. + +=back + +Note that ALL facet types have a 'details' key that may have a string. This +string should always be human readable, and should be an explanation for the +facet. For an assertion this is the test name. For a plan this is the reason +for the plan (such as skip reason). For info it is the human readable +diagnostics message. + +=head2 CUSTOM FACETS + +You can write custom facet types as well, simply add a new key to the hash and +populated it. The general rule is that any code looking at the facets should +ignore any it does not understand. + +Optionally you can also create a package to document your custom facet. The +package should be proper object, and may have additional methods to help work +with your facet. + + package Test2::EventFacet::MyFacet; + + use parent 'Test2::EventFacet'; + + sub facet_key { 'myfacet' } + sub is_list { 0 } + + 1; + +Your facet package should always be under the Test2::EventFacet:: namespace if +you want any tools to automatically find it. The last part of the namespace +should be the non-plural name of your facet with only the first word +capitalized. + +=over 4 + +=item $string = $facet_class->facet_key + +The key for your facet should be the same as the last section of +the namespace, but all lowercase. You I append 's' to the key if your +facet is a list type. + +=item $bool = $facet_class->is_list + +True if an event should put these facets in a list: + + { myfacet => [{}, {}] } + +False if an event may only have one of this type of facet at a time: + + { myfacet => {} } + +=back + +=head3 EXAMPLES + +The assert facet is not a list type, so its implementation would look like this: + + package Test2::EventFacet::Assert; + sub facet_key { 'assert' } + sub is_list { 0 } + +The amnesty facet is a list type, but amnesty does not need 's' appended to +make it plural: + + package Test2::EventFacet::Amnesty; + sub facet_key { 'amnesty' } + sub is_list { 1 } + +The error facet is a list type, and appending 's' makes error plural as errors. +This means the package name is '::Error', but the key is 'errors'. + + package Test2::EventFacet::Error; + sub facet_key { 'errors' } + sub is_list { 1 } + +B In practice most tools completely ignore the facet packages, and work +with the facet data directly in its raw structure. This is by design and +recommended. The facet data is intended to be serialized frequently and passed +around. When facets are concerned, data is important, classes and methods are +not. + +=head1 THE OLD API + +The old API was simply a set of methods you were required to implement: + +=over 4 + +=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 $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 $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. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Hubs.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Hubs.pm new file mode 100644 index 000000000000..70e4592dc5bf --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Hubs.pm @@ -0,0 +1,120 @@ +package Test2::Manual::Anatomy::Hubs; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Anatomy::Hubs - Internals documentation for the hub stack, and +hubs. + +=head1 DESCRIPTION + +This document describes the hub stack, and the hubs it contains. It explains +why we have a stack, and when to add/remove hubs from it. + +=head1 WHAT IS A HUB? + +Test2 is an event system, tools generate events, those events are then +processed to modify the testing state (number of tests, number of failures, +etc). The hub is responsible for receiving and processing events to record the +change in state. All events should eventually reach a destination hub. + +The base hub is L. All hub classes should inherit from the base hub +class. The base hub class provides several hooks that allow you to monitor or +modify events. Hubs are also responsible for forwarding events to the output +formatter. + +=head1 WHY DO WE HAVE A HUB STACK? + +There are cases where it makes sense to have more than one hub: + +=over 4 + +=item subtests + +In Test2 subtests are implemented using the hub stack. When you start a subtest +a new L instance is created and pushed to the stack. Once +this is done all calls to C will find the new hub and send +all events to it. When the subtest tool is complete it will remove the new hub, +and send a final subtest event to the parent hub. + +=item testing your test tools + +C is implemented using the hub stack. The +C function will add an L +instance to the stack, any calls to L will find the new +hub, and send it all events. The intercept hub is special in that is has no +connection to the parent hub, and usually does not have a formatter. + +=back + +=head1 WHEN SHOULD I ADD A HUB TO THE STACK? + +Any time you want to intercept or block events from effecting the test state. +Adding a new hub is essentially a way to create a sandbox where you have +absolute control over what events do. Adding a new hub insures that the main +test state will not be effected. + +=head1 WHERE IS THE STACK? + +The stack is an instance of L. You can access the global hub +stack using C. + +=head1 WHAT ABOUT THE ROOT HUB? + +The root hub is created automatically as needed. A call to +C<< Test2::API::test2_stack->top() >> will create the root hub if it does not +already exist. + +=head1 HOW DO HUBS HANDLE IPC? + +If the IPC system (L) was not loaded, then IPC is not handled at +all. Forking or creating new threads without the IPC system can cause +unexpected problems. + +All hubs track the PID and Thread ID that was current when they were created. +If an event is sent to a hub in a new process/thread the hub will detect this +and try to forward the event along to the correct process/thread. This is +accomplished using the IPC system. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/IPC.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/IPC.pm new file mode 100644 index 000000000000..36242a8a31f6 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/IPC.pm @@ -0,0 +1,90 @@ +package Test2::Manual::Anatomy::IPC; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Anatomy::IPC - Manual for the IPC system. + +=head1 DESCRIPTION + +This document describes the IPC system. + +=head1 WHAT IS THE IPC SYSTEM + +The IPC system is activated by loading L. This makes hubs +process/thread aware, and makes them forward events along to the parent +process/thread as necessary. + +=head1 HOW DOES THE IPC SYSTEM EFFECT EVERYTHING? + +L and L have some behaviors that trigger if +L is loaded before the global state is initialized. Mainly an IPC +driver will be initiated and stored in the global state. + +If an IPC driver is initialized then all hubs will be initialized with a +reference to the driver instance. If a hub has an IPC driver instance it will +use it to forward events to parent processes and threads. + +=head1 WHAT DOES AN IPC DRIVER DO? + +An L provides a way to send event data to a destination +process+thread+hub (or to all globally). The driver must also provide a way for +a process/thread/hub to read in any pending events that have been sent to it. + +=head1 HOW DOES THE DEFAULT IPC DRIVER WORK? + +The default IPC driver is L. This default driver, +when initialized, starts by creating a temporary directory. Any time an event +needs to be sent to another process/thread/hub, the event will be written to a +file using L. The file is written with the destination process, +thread, and hub as part of the filename. All hubs will regularly check for +pending IPC events and will process them. + +This driver is further optimized using a small chunk of SHM. Any time a new +event is sent via IPC the shm is updated to have a new value. Hubs will not +bother checking for new IPC events unless the shm value has changed since their +last poll. A result of this is that the IPC system is surprisingly fast, and +does not waste time polling the hard drive when there are no pending events. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Utilities.pm b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Utilities.pm new file mode 100644 index 000000000000..f251ef830198 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Anatomy/Utilities.pm @@ -0,0 +1,76 @@ +package Test2::Manual::Anatomy::Utilities; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Anatomy::Utilities - Overview of utilities for Test2. + +=head1 DESCRIPTION + +This is a brief overview of the utilities provided by Test2. + +=head1 Test2::Util + +L provides functions to help you find out about the current +system, or to run generic tasks that tend to be Test2 specific. + +This utility provides things like an internal C implementation, and +constants for things like threading and forking support. + +=head1 Test2::Util::ExternalMeta + +L allows you to quickly and easily attach meta-data +to an object class. + +=head1 Test2::Util::Facets2Legacy + +L is a set of functions you can import into a more +recent event class to provide the classic event API. + +=head1 Test2::Util::HashBase + +L is a local copy of L. All object +classes provided by L use this to generate methods and accessors. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Concurrency.pm b/cpan/Test2-Suite/lib/Test2/Manual/Concurrency.pm new file mode 100644 index 000000000000..dd5549448219 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Concurrency.pm @@ -0,0 +1,143 @@ +package Test2::Manual::Concurrency; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Concurrency - Documentation for Concurrency support. + +=head1 FORKING + +=head2 Test2 + +Test2 supports forking. For forking to work you need to load L. + +=head2 Test::Builder + +L Did not used to support forking, but now that it is based on +L it does. L must be loaded just as with L. + +=head2 Test2::Suite + +L tools should all work fine with I forking unless +otherwise noted. Pseudo-fork via threads (Windows and a few others) is not +supported, but may work. + +Patches will be accepted to repair any pseudo-fork issues, but for these to be +used or tested they must be requested. Fork tests should not run on pseudo-fork +systems unless they are requested with an environment var, or the +AUTHOR_TESTING var. Pseudo-fork is fragile, and we do not want to block install +due to a pseudo-fork flaw. + +=head2 Test::SharedFork + +L is currently support and maintained, though it is no longer +necessary thanks to L. If usage ever drops off then the module may +be deprecated, but for now the policy is to not let it break. Currently it +simply loads L if it can, and falls back to the old methods on +legacy installs. + +=head2 Others + +Individual authors are free to support or not support forking as they see fit. + +=head1 THREADING + +B This only applies to ithreads. + +=head2 Test2 + +The core of Test2 supports threading so long as L is loaded. Basic +threading support (making sure events make it to the parent thread) is fully +supported, and must not be broken. + +Some times perl installs have broken threads (Some 5.10 versions compiled on +newer gcc's will segv by simply starting a thread). This is beyond Test2's +control, and not solvable in Test2. That said we strive for basic threading +support on perl 5.8.1+. + +If Test2 fails for threads on any perl 5.8 or above, and it is reasonably +possible for Test2 to work around the issue, it should. (Patches and bug +reports welcome). + +=head2 Test::Builder + +L has had thread support for a long time. With Test2 the +mechanism for thread support was switched to L. L +should still support threads as much as it did before the switch to Test2. +Support includes auto-enabling thread support if L is loaded before +Test::Builder. + +If there is a deviation between the new and old threading behavior then it is a +bug (unless the old behavior itself can be classified as a bug.) Please report +(or patch!) any such threading issues. + +=head2 Test2::Suite + +Tools in L have minimal threading support. Most of these tools do +not care/notice threading and simply work because L handles it. +Feel free to report any thread related bugs in Test2::Suite. Be aware though +that these tools are not legacy, and have no pre-existing thread support, we +reserve the right to refuse adding thread support to them. + +=head3 Test2::Workflow + +L has been merged into L, so it gets addressed +by this policy. + +L has thread support, but you must ask for it. Thread tests +for Test2::Workflow do not event run without setting either the AUTHOR_TESTING +env var, or the T2_DO_THREAD_TESTS env var. + +To use threads with Test2::Workflow you must set the T2_WORKFLOW_USE_THREADS +env var. + +If you do rely on threads with Test2::Workflow and find a bug please report it, +but it will be given an ultra-low priority. Merging patches that fix threading +issues will be given normal priority. + +=head1 SEE ALSO + +L - Test2 itself. + +L - Initial tools built using L. + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Contributing.pm b/cpan/Test2-Suite/lib/Test2/Manual/Contributing.pm new file mode 100644 index 000000000000..4b9915dab691 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Contributing.pm @@ -0,0 +1,115 @@ +package Test2::Manual::Contributing; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Contributing - How to contribute to the Test2 project. + +=head1 DESCRIPTION + +This is a short manual page dedicated to helping people who wish to contribute +to the Test2 project. + +=head1 WAYS TO HELP + +=head2 REPORT BUGS + +The easiest way to help is to report bugs when you find them. Bugs are a fact +of life when writing or using software. If you use Test2 long enough you are +likely to find a bug. When you find such a bug it would help us out if you +would submit a ticket. + +=head3 BUG TRACKERS + +Always try to find the preferred bug tracker for the module that has the bug. +Here are the big 3 for the main Test2 project: + +=over 4 + +=item Test2/Test-Builder/Test-More + +L + +=item Test2-Suite + +L + +=item Test2-Harness + +L + +=back + +=head2 SUBMIT PATCHES + +You are welcome to fix bugs you find, or from the tracker. We also often accept +patches that add new features or update documentation. The preferred method of +submitting patches is a github pull request, that said we also accept patches +via email. + +=head2 ADD/UPDATE DOCUMENTATION + +Documentation can be flawed just like code can be. Documentation can also +become outdated. If you see some incorrect documentation, or documentation that +is missing, we would love to get a patch to fix it! + +=head2 ANSWER QUESTIONS ON IRC/SLACK + +We are always hanging out on L, the #perl-qa and #toolchain +channels are a good place to find us. + +There is also a Test2 slack channel: L. + +=head2 WRITE NEW TOOLS USING TEST2 + +Writing a new tool using Test2 is always a good way to contribute. When you +write a tool that you think is useful, it is nice to share it by putting it on +CPAN. + +=head2 PORT OLD TOOLS TO TEST2 + +The C namespace has been around for a long time, and has a LOT of +tools. The C namespace is fairly young, and has less tools. +Finding a useful old tool with no modern equivalent, and writing a port is a +very good use of your time. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Testing.pm b/cpan/Test2-Suite/lib/Test2/Manual/Testing.pm new file mode 100644 index 000000000000..908279993794 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Testing.pm @@ -0,0 +1,245 @@ +package Test2::Manual::Testing; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Testing - Hub for documentation about writing tests with Test2. + +=head1 DESCRIPTION + +This document outlines all the tutorials and POD that cover writing tests. This +section does not cover any Test2 internals, nor does it cover how to write new +tools, for that see L. + +=head1 NAMESPACE MAP + +When writing tests there are a couple namespaces to focus on: + +=over 4 + +=item Test2::Tools::* + +This is where toolsets can be found. A toolset exports functions that help you +make assertions about your code. Toolsets will only export functions, they +should not ever have extra/global effects. + +=item Test2::Plugins::* + +This is where plugins live. Plugins should not export anything, but instead +will introduce or alter behaviors for Test2 in general. These behaviors may be +lexically scoped, or they may be global. + +=item Test2::Bundle::* + +Bundles combine toolsets and plugins together to reduce your boilerplate. First +time test writers are encouraged to start with the L bundle (which +is an exception to the namespace rule as it does not live under +C). If you find yourself loading several plugins and toolsets +over and over again you could benefit from writing your own bundle. + +=item Test2::Require::* + +This namespace contains modules that will cause a test to skip if specific +conditions are not met. Use this if you have tests that only run on specific +perl versions, or require external libraries that may not always be available. + +=back + +=head1 LISTING DEPENDENCIES + +When you use L, specifically things included in L you need +to list them in your modules test dependencies. It is important to note that +you should list the tools/plugins/bundles you need, you should not simply list +L as your dependency. L is a living distribution +intended to represent the "current" best practices. As tools, plugins, and +bundles evolve, old ones will become discouraged and potentially be moved from +L into their own distributions. + +One goal of L is to avoid breaking backwards compatibility. +Another goal is to always improve by replacing bad designs with better ones. +When necessary L will break old modules out into separate dists +and define new ones, typically with a new bundle. In short, if we feel the need +to break something we will do so by creating a new bundle, and discouraging the +old one, but we will not break the old one. + +So for example, if you use L, and L you +should have this in your config: + + [Prereqs / TestRequires] + Test2::V0 = 0.000060 + +You B do this: + + [Prereqs / TestRequires] + Test2::Suite = 0.000060 + +Because L might not always be part of L. + +When writing new tests you should often check L to see what the +current recommended bundle is. + +=head3 Dist::Zilla + + [Prereqs / TestRequires] + Test2::V0 = 0.000060 + +=head3 ExtUtils::MakeMaker + + my %WriteMakefileArgs = ( + ..., + "TEST_REQUIRES" => { + "Test2::V0" => "0.000060" + }, + ... + ); + +=head3 Module::Install + + test_requires 'Test2::V0' => '0.000060'; + +=head3 Module::Build + + my $build = Module::Build->new( + ..., + test_requires => { + "Test2::V0" => "0.000060", + }, + ... + ); + +=head1 TUTORIALS + +=head2 SIMPLE/INTRODUCTION TUTORIAL + +L is an introduction to writing tests +using the L tools. + +=head2 MIGRATING FROM TEST::BUILDER and TEST::MORE + +L Is a tutorial for converting old tests +that use L or L to the newer L way of doing +things. + +=head2 ADVANCED PLANNING + +L is a tutorial on the many ways to set a +plan. + +=head2 TODO TESTS + +L is a tutorial for markings tests as TODO. + +=head2 SUBTESTS + +COMING SOON. + +=head2 COMPARISONS + +COMING SOON. + +=head3 SIMPLE COMPARISONS + +COMING SOON. + +=head3 ADVANCED COMPARISONS + +COMING SOON. + +=head2 TESTING EXPORTERS + +COMING SOON. + +=head2 TESTING CLASSES + +COMING SOON. + +=head2 TRAPPING + +COMING SOON. + +=head3 TRAPPING EXCEPTIONS + +COMING SOON. + +=head3 TRAPPING WARNINGS + +COMING SOON. + +=head2 DEFERRED TESTING + +COMING SOON. + +=head2 MANAGING ENCODINGS + +COMING SOON. + +=head2 AUTO-ABORT ON FAILURE + +COMING SOON. + +=head2 CONTROLLING RANDOM BEHAVIOR + +COMING SOON. + +=head2 WRITING YOUR OWN BUNDLE + +COMING SOON. + +=head1 TOOLSET DOCUMENTATION + +COMING SOON. + +=head1 PLUGIN DOCUMENTATION + +COMING SOON. + +=head1 BUNDLE DOCUMENTATION + +COMING SOON. + +=head1 REQUIRE DOCUMENTATION + +COMING SOON. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Testing/Introduction.pm b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Introduction.pm new file mode 100644 index 000000000000..28e7680d6600 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Introduction.pm @@ -0,0 +1,293 @@ +package Test2::Manual::Testing::Introduction; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Testing::Introduction - Introduction to testing with Test2. + +=head1 DESCRIPTION + +This tutorial is a beginners introduction to testing. This will take you +through writing a test file, making assertions, and running your test. + +=head1 BOILERPLATE + +=head2 THE TEST FILE + +Test files typically are placed inside the C directory, and end with the +C<.t> file extension. + +C: + + use Test2::V0; + + # Assertions will go here + + done_testing; + +This is all the boilerplate you need. + +=over 4 + +=item use Test2::V0; + +This loads a collection of testing tools that will be described later in the +tutorial. This will also turn on C and C for you. + +=item done_testing; + +This should always be at the end of your test files. This tells L that +you are done making assertions. This is important as C will assume the +test did not complete successfully without this, or some other form of test +"plan". + +=back + +=head2 DIST CONFIG + +You should always list bundles and tools directly. You should not simply list +L and call it done, bundles and tools may be moved out of +L to their own dists at any time. + +=head3 Dist::Zilla + + [Prereqs / TestRequires] + Test2::V0 = 0.000060 + +=head3 ExtUtils::MakeMaker + + my %WriteMakefileArgs = ( + ..., + "TEST_REQUIRES" => { + "Test2::V0" => "0.000060" + }, + ... + ); + +=head3 Module::Install + + test_requires 'Test2::V0' => '0.000060'; + +=head3 Module::Build + + my $build = Module::Build->new( + ..., + test_requires => { + "Test2::V0" => "0.000060", + }, + ... + ); + +=head1 MAKING ASSERTIONS + +The most simple tool for making assertions is C. C lets you assert +that a condition is true. + + ok($CONDITION, "Description of the condition"); + +Here is a complete C: + + use Test2::V0; + + ok(1, "1 is true, so this will pass"); + + done_testing; + +=head1 RUNNING THE TEST + +Test files are simply scripts. Just like any other script you can run the test +directly with perl. Another option is to use a test "harness" which runs the +test for you, and provides extra information and checks the scripts exit value +for you. + +=head2 RUN DIRECTLY + + $ perl -Ilib t/example.t + +Which should produce output like this: + + # Seeded srand with seed '20161028' from local date. + ok 1 - 1 is true, so this will pass + 1..1 + +If the test had failed (C) it would look like this: + + # Seeded srand with seed '20161028' from local date. + not ok 1 - 0 is false, so this will fail + 1..1 + +Test2 will also set the exit value of the script, a successful run will have an +exit value of 0, a failed run will have a non-zero exit value. + +=head2 USING YATH + +The C command line tool is provided by L which you may +need to install yourself from cpan. C is the harness written specifically +for L. + + $ yath -Ilib t/example.t + +This will produce output similar to this: + + ( PASSED ) job 1 t/example.t + + ================================================================================ + + Run ID: 1508027909 + + All tests were successful! + +You can also request verbose output with the C<-v> flag: + + $ yath -Ilib -v t/example.t + +Which produces: + + ( LAUNCH ) job 1 example.t + ( NOTE ) job 1 Seeded srand with seed '20171014' from local date. + [ PASS ] job 1 + 1 is true, so this will pass + [ PLAN ] job 1 Expected asserions: 1 + ( PASSED ) job 1 example.t + + ================================================================================ + + Run ID: 1508028002 + + All tests were successful! + +=head2 USING PROVE + +The C command line tool is provided by the L module which +comes with most versions of perl. L is dual-life, which means +you can also install the latest version from cpan. + + $ prove -Ilib t/example.t + +This will produce output like this: + + example.t .. ok + All tests successful. + Files=1, Tests=1, 0 wallclock secs ( 0.01 usr 0.00 sys + 0.05 cusr 0.00 csys = 0.06 CPU) + Result: PASS + +You can also request verbose output with the C<-v> flag: + + $ prove -Ilib -v t/example.t + +The verbose output looks like this: + + example.t .. + # Seeded srand with seed '20161028' from local date. + ok 1 - 1 is true, so this will pass + 1..1 + ok + All tests successful. + Files=1, Tests=1, 0 wallclock secs ( 0.02 usr 0.00 sys + 0.06 cusr 0.00 csys = 0.08 CPU) + Result: PASS + +=head1 THE "PLAN" + +All tests need a "plan". The job of a plan is to make sure you ran all the +tests you expected. The plan prevents a passing result from a test that exits +before all the tests are run. + +There are 2 primary ways to set the plan: + +=over 4 + +=item done_testing() + +The most common, and recommended way to set a plan is to add C at +the end of your test file. This will automatically calculate the plan for you +at the end of the test. If the test were to exit early then C +would not run and no plan would be found, forcing a failure. + +=item plan($COUNT) + +The C function allows you to specify an exact number of assertions you +want to run. If you run too many or too few assertions then the plan will not +match and it will be counted as a failure. The primary problem with this way of +planning is that you need to add up the number of assertions, and adjust the +count whenever you update the test file. + +C must be used before all assertions, or after all assertions, it +cannot be done in the middle of making assertions. + +=back + +=head1 ADDITIONAL ASSERTION TOOLS + +The L bundle provides a lot more than C, +C, and C. The biggest tools to note are: + +=over 4 + +=item is($a, $b, $description) + +C allows you to compare 2 structures and insure they are identical. You +can use it for simple string comparisons, or even deep data structure +comparisons. + + is("foo", "foo", "Both strings are identical"); + + is(["foo", 1], ["foo", 1], "Both arrays contain the same elements"); + +=item like($a, $b, $description) + +C is similar to C except that it only checks items listed on the +right, it ignores any extra values found on the left. + + like([1, 2, 3, 4], [1, 2, 3], "Passes, the extra element on the left is ignored"); + +You can also used regular expressions on the right hand side: + + like("foo bar baz", qr/bar/, "The string matches the regex, this passes"); + +You can also nest the regexes: + + like([1, 2, 'foo bar baz', 3], [1, 2, qr/bar/], "This passes"); + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Testing/Migrating.pm b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Migrating.pm new file mode 100644 index 000000000000..9c8d0436d829 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Migrating.pm @@ -0,0 +1,420 @@ +package Test2::Manual::Testing::Migrating; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +=head1 NAME + +Test2::Manual::Testing::Migrating - How to migrate existing tests from +Test::More to Test2. + +=head1 DESCRIPTION + +This tutorial covers the conversion of an existing test. This tutorial assumes +you have a test written using L. + +=head1 LEGACY TEST + +This tutorial will be converting this example test one section at a time: + +C: + + ##################### + # Boilerplate + + use strict; + use warnings; + + use Test::More tests => 14; + + use_ok 'Scalar::Util'; + require_ok 'Exporter'; + + ##################### + # Simple assertions (no changes) + + ok(1, "pass"); + + is("apple", "apple", "Simple string compare"); + + like("foo bar baz", qr/bar/, "Regex match"); + + ##################### + # Todo + + { + local $TODO = "These are todo"; + + ok(0, "oops"); + } + + ##################### + # Deep comparisons + + is_deeply([1, 2, 3], [1, 2, 3], "Deep comparison"); + + ##################### + # Comparing references + + my $ref = [1]; + is($ref, $ref, "Check that we have the same ref both times"); + + ##################### + # Things that are gone + + ok(eq_array([1], [1]), "array comparison"); + ok(eq_hash({a => 1}, {a => 1}), "hash comparison"); + ok(eq_set([1, 3, 2], [1, 2, 3]), "set comparison"); + + note explain([1, 2, 3]); + + { + package THING; + sub new { bless({}, shift) } + } + + my $thing = new_ok('THING'); + + ##################### + # Tools that changed + + isa_ok($thing, 'THING', '$thing'); + + can_ok(__PACKAGE__, qw/ok is/); + +=head1 BOILERPLATE + +BEFORE: + + use strict; + use warnings; + + use Test::More tests => 14; + + use_ok 'Scalar::Util'; + require_ok 'Exporter'; + +AFTER: + + use Test2::V0; + plan(11); + + use Scalar::Util; + require Exporter; + +=over 4 + +=item Replace Test::More with Test2::V0 + +L is the recommended bundle. In a full migration you +will want to replace L with the L bundle. + +B You should always double check the latest L to see if there is +a new recommended bundle. When writing a new test you should always use the +newest Test::V# module. Higher numbers are newer version. + +=item Stop using use_ok() + +C has been removed. a C statement will throw an exception +on failure anyway preventing the test from passing. + +If you I want/need to assert that the file loaded you can use the L +module: + + use ok 'Scalar::Util'; + +The main difference here is that there is a space instead of an underscore. + +=item Stop using require_ok() + +C has been removed just like C. There is no L module +equivalent here. Just use C. + +=item Remove strict/warnings (optional) + +The L bundle turns strict and warnings on for you. + +=item Change where the plan is set + +Test2 does not allow you to set the plan at import. In the old code you would +pass C<< tests => 11 >> as an import argument. In L you either need to +use the C function to set the plan, or use C at the end +of the test. + +If your test already uses C you can keep that and no plan +changes are necessary. + +B We are also changing the plan from 14 to 11, that is because we +dropped C, C, and we will be dropping one more later on. +This is why C is recommended over a set plan. + +=back + +=head1 SIMPLE ASSERTIONS + +The vast majority of assertions will not need any changes: + + ##################### + # Simple assertions (no changes) + + ok(1, "pass"); + + is("apple", "apple", "Simple string compare"); + + like("foo bar baz", qr/bar/, "Regex match"); + +=head1 TODO + + { + local $TODO = "These are todo"; + + ok(0, "oops"); + } + +The C<$TODO> package variable is gone. You now have a C function. + +There are 2 ways this can be used: + +=over 4 + +=item todo $reason => sub { ... } + + todo "These are todo" => sub { + ok(0, "oops"); + }; + +This is the cleanest way to do a todo. This will make all assertions inside the +codeblock into TODO assertions. + +=item { my $TODO = todo $reason; ... } + + { + my $TODO = todo "These are todo"; + + ok(0, "oops"); + } + +This is a system that emulates the old way. Instead of modifying a global +C<$TODO> variable you create a todo object with the C function and +assign it to a lexical variable. Once the todo object falls out of scope the +TODO ends. + +=back + +=head1 DEEP COMPARISONS + + is_deeply([1, 2, 3], [1, 2, 3], "Deep comparison"); + +Deep comparisons are easy, simply replace C with C. + + is([1, 2, 3], [1, 2, 3], "Deep comparison"); + +=head1 COMPARING REFERENCES + + my $ref = [1]; + is($ref, $ref, "Check that we have the same ref both times"); + +The C function provided by L forces both arguments into +strings, which makes this a comparison of the reference addresses. L's +C function is a deep comparison, so this will still pass, but fails to +actually test what we want (that both references are the same exact ref, not +just identical structures.) + +We now have the C function that does what we really want, it ensures +both references are the same reference. This function does the job better than +the original, which could be thrown off by string overloading. + + my $ref = [1]; + ref_is($ref, $ref, "Check that we have the same ref both times"); + +=head1 TOOLS THAT ARE GONE + + ok(eq_array([1], [1]), "array comparison"); + ok(eq_hash({a => 1}, {a => 1}), "hash comparison"); + ok(eq_set([1, 3, 2], [1, 2, 3]), "set comparison"); + + note explain([1, 2, 3]); + + { + package THING; + sub new { bless({}, shift) } + } + + my $thing = new_ok('THING'); + +C, C and C have been considered deprecated for a +very long time, L does not provide them at all. Instead you can just use +C: + + is([1], [1], "array comparison"); + is({a => 1}, {a => 1}, "hash comparison"); + +C is a tad more complicated, see L for an +explanation: + + is([1, 3, 2], bag { item 1; item 2; item 3; end }, "set comparison"); + +C has a rocky history. There have been arguments about how it should +work. L decided to simply not include C to avoid the +arguments. You can instead directly use Data::Dumper: + + use Data::Dumper; + note Dumper([1, 2, 3]); + +C is gone. The implementation was complicated, and did not add much +value: + + { + package THING; + sub new { bless({}, shift) } + } + + my $thing = THING->new; + ok($thing, "made a new thing"); + +The complete section after the conversion is: + + is([1], [1], "array comparison"); + is({a => 1}, {a => 1}, "hash comparison"); + is([1, 3, 2], bag { item 1; item 2; item 3; end }, "set comparison"); + + use Data::Dumper; + note Dumper([1, 2, 3]); + + { + package THING; + sub new { bless({}, shift) } + } + + my $thing = THING->new; + ok($thing, "made a new thing"); + +=head1 TOOLS THAT HAVE CHANGED + + isa_ok($thing, 'THING', '$thing'); + + can_ok(__PACKAGE__, qw/ok is/); + +In L these functions are very confusing, and most people use them +wrong! + +C from L takes a thing, a class/reftype to check, and +then uses the third argument as an alternative display name for the first +argument (NOT a test name!). + +C from L is not consistent with C as all +arguments after the first are subroutine names. + +L fixes this by making both functions consistent and obvious: + + isa_ok($thing, ['THING'], 'got a THING'); + + can_ok(__PACKAGE__, [qw/ok is/], "have expected subs"); + +You will note that both functions take a thing, an arrayref as the second +argument, then a test name as the third argument. + +=head1 FINAL VERSION + + ##################### + # Boilerplate + + use Test2::V0; + plan(11); + + use Scalar::Util; + require Exporter; + + ##################### + # Simple assertions (no changes) + + ok(1, "pass"); + + is("apple", "apple", "Simple string compare"); + + like("foo bar baz", qr/bar/, "Regex match"); + + ##################### + # Todo + + todo "These are todo" => sub { + ok(0, "oops"); + }; + + ##################### + # Deep comparisons + + is([1, 2, 3], [1, 2, 3], "Deep comparison"); + + ##################### + # Comparing references + + my $ref = [1]; + ref_is($ref, $ref, "Check that we have the same ref both times"); + + ##################### + # Things that are gone + + is([1], [1], "array comparison"); + is({a => 1}, {a => 1}, "hash comparison"); + + is([1, 3, 2], bag { item 1; item 2; item 3; end }, "set comparison"); + + use Data::Dumper; + note Dumper([1, 2, 3]); + + { + package THING; + sub new { bless({}, shift) } + } + + my $thing = THING->new; + + ##################### + # Tools that changed + + isa_ok($thing, ['THING'], 'got a THING'); + + can_ok(__PACKAGE__, [qw/ok is/], "have expected subs"); + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Testing/Planning.pm b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Planning.pm new file mode 100644 index 000000000000..9eca86a87234 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Planning.pm @@ -0,0 +1,104 @@ +package Test2::Manual::Testing::Planning; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Testing::Planning - The many ways to set a plan. + +=head1 DESCRIPTION + +This tutorial covers the many ways of setting a plan. + +=head1 TEST COUNT + +The C function is provided by L. This function lets +you specify an exact number of tests to run. This can be done at the start of +testing, or at the end. This cannot be done partway through testing. + + use Test2::Tools::Basic; + plan(10); # 10 tests expected + + ... + +=head1 DONE TESTING + +The C function is provided by L. This +function will automatically set the plan to the number of tests that were run. +This must be used at the very end of testing. + + use Test2::Tools::Basic; + + ... + + done_testing(); + +=head1 SKIP ALL + +The C function is provided by L. This function +will set the plan to C<0>, and exit the test immediately. You may provide a skip +reason that explains why the test should be skipped. + + use Test2::Tools::Basic; + skip_all("This test will not run here") if ...; + + ... + +=head1 CUSTOM PLAN EVENT + +A plan is simply an L event that gets sent to the current +hub. You could always write your own tool to set the plan. + + use Test2::API qw/context/; + + sub set_plan { + my $count = @_; + + my $ctx = context(); + $ctx->send_event('Plan', max => $count); + $ctx->release; + + return $count; + } + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Testing/Todo.pm b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Todo.pm new file mode 100644 index 000000000000..a553ee5f4aa5 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Testing/Todo.pm @@ -0,0 +1,112 @@ +package Test2::Manual::Testing::Todo; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Testing::Todo - Tutorial for marking tests as TODO. + +=head1 DESCRIPTION + +This tutorial covers the process of marking tests as TODO. It also describes +how TODO works under the hood. + +=head1 THE TOOL + + use Test2::Tools::Basic qw/todo/; + +=head2 TODO BLOCK + +This form is low-magic. All tests inside the block are marked as todo, tests +outside the block are not todo. You do not need to do any variable management. +The flaw with this form is that it adds a couple levels to the stack, which can +break some high-magic tests. + +Overall this is the preferred form unless you have a special case that requires +the variable form. + + todo "Reason for the todo" => sub { + ok(0, "fail but todo"); + ... + }; + +=head2 TODO VARIABLE + +This form maintains the todo scope for the life of the variable. This is useful +for tests that are sensitive to scope changes. This closely emulates the +L style which localized the C<$TODO> package variable. Once the +variable is destroyed (set it to undef, scope end, etc) the TODO state ends. + + my $todo = todo "Reason for the todo"; + ok(0, "fail but todo"); + ... + $todo = undef; + +=head1 MANUAL TODO EVENTS + + use Test2::API qw/context/; + + sub todo_ok { + my ($bool, $name, $todo) = @_; + + my $ctx = context(); + $ctx->send_event('Ok', pass => $bool, effective_pass => 1, todo => $todo); + $ctx->release; + + return $bool; + } + +The L event has a C field which should have the todo +reason. The event also has the C and C fields. The +C field is the actual pass/fail value. The C is used to +determine if the event is an actual failure (should always be set tot true with +todo). + +=head1 HOW THE TODO TOOLS WORK UNDER THE HOOD + +The L library gets the current L instance and adds a +filter. The filter that is added will set the todo and effective pass fields on +any L events that pass through the hub. The filter also +converts L events into L events. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling.pm new file mode 100644 index 000000000000..789133782767 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling.pm @@ -0,0 +1,120 @@ +package Test2::Manual::Tooling; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling - Manual page for tool authors. + +=head1 DESCRIPTION + +This section covers writing new tools, plugins, and other Test2 components. + +=head1 TOOL TUTORIALS + +=head2 FIRST TOOL + +L - Introduction to writing tools by cloning +L. + +=head2 MOVING FROM Test::Builder + +L - This section maps Test::Builder +methods to Test2 concepts. + +=head2 NESTING TOOLS + +L - How to call other tools from your tool. + +=head2 TOOLS WITH SUBTESTS + +L - How write tools that make use of subtests. + +=head2 TESTING YOUR TEST TOOLS + +L - How to write tests for your test tools. + +=head1 PLUGIN TUTORIALS + +=head2 TAKING ACTION WHEN A NEW TOOL STARTS + +L - How to add behaviors that occur +when a tool starts work. + +=head2 TAKING ACTION AFTER A TOOL IS DONE + +L - How to add behaviors that +occur when a tool completes work. + +=head2 TAKING ACTION AT THE END OF TESTING + +L - How to add behaviors that +occur when testing is complete (IE done_testing, or end of test). + +=head2 TAKING ACTION JUST BEFORE EXIT + +L - How to safely add pre-exit +behaviors. + +=head1 WRITING A SIMPLE JSONL FORMATTER + +L - How to write a custom formatter, in our +case a JSONL formatter. + +=head1 WHERE TO FIND HOOKS AND APIS + +=over 4 + +=item global API + +L is the global API. This is primarily used by plugins that provide +global behavior. + +=item In hubs + +L is the base class for all hubs. This is where hooks for +manipulating events, or running things at the end of testing live. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/FirstTool.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/FirstTool.pm new file mode 100644 index 000000000000..b0ccd4eaad91 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/FirstTool.pm @@ -0,0 +1,145 @@ +package Test2::Manual::Tooling::FirstTool; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::FirstTool - Write your first tool with Test2. + +=head1 DESCRIPTION + +This tutorial will help you write your very first tool by cloning the C +tool. + +=head1 COMPLETE CODE UP FRONT + + package Test2::Tools::MyOk; + use strict; + use warnings; + + use Test2::API qw/context/; + + use base 'Exporter'; + our @EXPORT = qw/ok/; + + sub ok($;$@) { + my ($bool, $name, @diag) = @_; + + my $ctx = context(); + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); + } + + 1; + +=head1 LINE BY LINE + +=over 4 + +=item sub ok($;$@) { + +In this case we are emulating the C function exported by +L. + +C and similar test tools use prototypes to enforce argument parsing. Your +test tools do not necessarily need prototypes, like any perl function you need +to make the decision based on how it is used. + +The prototype requires at least 1 argument, which will +be forced into a scalar context. The second argument is optional, and is also +forced to be scalar, it is the name of the test. Any remaining arguments are +treated as diagnostics messages that will only be used if the test failed. + +=item my ($bool, $name, @diag) = @_; + +This line does not need much explanation, we are simply grabbing the args. + +=item my $ctx = context(); + +This is a vital line in B tools. The context object is the primary API for +test tools. You B get a context if you want to issue any events, such as +making assertions. Further, the context is responsible for making sure failures +are attributed to the correct file and line number. + +B A test function B always release the context when it is done, +you cannot simply let it fall out of scope and be garbage collected. Test2 does +a pretty good job of yelling at you if you make this mistake. + +B You B ever store or pass around a I context object. If +you wish to hold on to a context for any reason you must use clone to make a +copy C<< my $copy = $ctx->clone >>. The copy may be passed around or stored, +but the original B be released when you are done with it. + +=item return $ctx->pass_and_release($name) if $bool; + +When C<$bool> is true, this line uses the context object to issue a +L event. Along with issuing the event this will also +release the context object and return true. + +This is short form for: + + if($bool) { + $ctx->pass($name); + $ctx->release; + return 1; + } + +=item return $ctx->fail_and_release($name, @diag); + +This line issues a L event, releases the context object, +and returns false. The fail event will include any diagnostics messages from +the C<@diag> array. + +This is short form for: + + $ctx->fail($name, @diag); + $ctx->release; + return 0; + +=back + +=head1 CONTEXT OBJECT DOCUMENTATION + +L is the place to read up on what methods the context +provides. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Formatter.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Formatter.pm new file mode 100644 index 000000000000..a21c6126f27d --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Formatter.pm @@ -0,0 +1,138 @@ +package Test2::Manual::Tooling::Formatter; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Formatter - How to write a custom formatter, in our +case a JSONL formatter. + +=head1 DESCRIPTION + +This tutorial explains a minimal formatter that outputs each event as a json +string on its own line. A true formatter will probably be significantly more +complicated, but this will give you the basics needed to get started. + +=head1 COMPLETE CODE UP FRONT + + package Test2::Formatter::MyFormatter; + use strict; + use warnings; + + use JSON::MaybeXS qw/encode_json/; + + use base qw/Test2::Formatter/; + + sub new { bless {}, shift } + + sub encoding {}; + + sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + print encode_json($f), "\n"; + } + + 1; + +=head1 LINE BY LINE + +=over 4 + +=item use base qw/Test2::Formatter/; + +All formatters should inherit from L. + +=item sub new { bless {}, shift } + +Formatters need to be instantiable objects, this is a minimal C method. + +=item sub encoding {}; + +For this example we leave this sub empty. In general you should implement this +sub to make sure you honor situations where the encoding is set. L +itself will try to set the encoding to UTF8. + +=item sub write { ... } + +The C method is the most important, each event is sent here. + +=item my ($self, $e, $num, $f) = @_; + +The C method receives 3 or 4 arguments, the fourth is optional. + +=over 4 + +=item $self + +The formatter itself. + +=item $e + +The event being written + +=item $num + +The most recent assertion number. If the event being processed is an assertion +then this will have been bumped by 1 since the last call to write. For non +assertions this number is set to the most recent assertion. + +=item $f + +This MAY be a hashref containing all the facet data from the event. More often +then not this will be undefined. This is only set if the facet data was needed +by the hub, and it usually is not. + +=back + +=item $f ||= $e->facet_data; + +We want to dump the event facet data. This will set C<$f> to the facet data +unless we already have the facet data. + +=item print encode_json($f), "\n"; + +This line prints the JSON encoded facet data, and a newline. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Nesting.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Nesting.pm new file mode 100644 index 000000000000..799e4690e4ca --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Nesting.pm @@ -0,0 +1,140 @@ +package Test2::Manual::Tooling::Nesting; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Nesting - Tutorial for using other tools within your +own. + +=head1 DESCRIPTION + +Sometimes you find yourself writing the same test pattern over and over, in +such cases you may want to encapsulate the logic in a new test function that +calls several tools together. This sounds easy enough, but can cause headaches +if not done correctly. + +=head1 NAIVE WAY + +Lets say you find yourself writing the same test pattern over and over for multiple objects: + + my $obj1 = $class1->new; + is($obj1->foo, 'foo', "got foo"); + is($obj1->bar, 'bar', "got bar"); + + my $obj2 = $class1->new; + is($obj2->foo, 'foo', "got foo"); + is($obj2->bar, 'bar', "got bar"); + + ... 10x more times for classes 2-12 + +The naive way to do this is to write a C function like this: + + sub check_class { + my $class = shift; + my $obj = $class->new; + is($obj->foo, 'foo', "got foo"); + is($obj->bar, 'bar', "got bar"); + } + + check_class($class1); + check_class($class2); + check_class($class3); + ... + +This will appear to work fine, and you might not notice any problems, +I + +=head2 WHATS WRONG WITH IT? + +The problems with the naive approach become obvious if things start to fail. +The diagnostics that tell you what file and line the failure occurred on will be +wrong. The failure will be reported to the line I C, not +to the line where C was called. This is problem because it +leaves you with no idea which class is failing. + +=head2 HOW TO FIX IT + +Luckily this is extremely easy to fix. You need to acquire a context object at +the start of your function, and release it at the end... yes it is that simple. + + use Test2::API qw/context/; + + sub check_class { + my $class = shift; + + my $ctx = context(); + + my $obj = $class->new; + is($obj->foo, 'foo', "got foo"); + is($obj->bar, 'bar', "got bar"); + + $ctx->release; + } + +See, that was easy. With these 2 additional lines we know have proper file+line +reporting. The nested tools will find the context we acquired here, and know to +use it's file and line numbers. + +=head3 THE OLD WAY (DO NOT DO THIS ANYMORE) + +With L there was a global variables called +C<$Test::Builder::Level> which helped solve this problem: + + sub check_class { + my $class = shift; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + my $obj = $class->new; + is($obj->foo, 'foo', "got foo"); + is($obj->bar, 'bar', "got bar"); + } + +This variable worked well enough (and will still work) but was not very +discoverable. Another problem with this variable is that it becomes cumbersome +if you have a more deeply nested code structure called the nested tools, you +might need to count stack frames, and hope they never change due to a third +party module. The context solution has no such caveats. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestExit.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestExit.pm new file mode 100644 index 000000000000..94ff76a0eda7 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestExit.pm @@ -0,0 +1,108 @@ +package Test2::Manual::Tooling::Plugin::TestExit; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Plugin::TestExit - How to safely add pre-exit +behaviors. + +=head1 DESCRIPTION + +This describes the correct/safe way to add pre-exit behaviors to tests via a +custom plugin. + +The naive way to attempt this would be to add an C block. That can +work, and may not cause problems.... On the other hand there are a lot of ways +that can bite you. Describing all the potential problems of an END block, and +how it might conflict with Test2 (Which has its own END block) is beyond the +scope of this document. + +=head1 COMPLETE CODE UP FRONT + + package Test2::Plugin::MyPlugin; + + use Test2::API qw{test2_add_callback_exit}; + + sub import { + my $class = shift; + + test2_add_callback_exit(sub { + my ($ctx, $orig_code, $new_exit_code_ref) = @_; + + return if $orig_code == 42; + + $$new_exit_code_ref = 42; + }); + } + + 1; + +=head1 LINE BY LINE + +=over 4 + +=item use Test2::API qw{test2_add_callback_exit}; + +This imports the C<(test2_add_callback_exit)> callback. + +=item test2_add_callback_exit(sub { ... }); + +This adds our callback to be called before exiting. + +=item my ($ctx, $orig_code, $new_exit_code_ref) = @_ + +The callback gets 3 arguments. First is a context object you may use. The +second is the original exit code of the C block Test2 is using. The third +argument is a scalar reference which you may use to get the current exit code, +or set a new one. + +=item return if $orig_code == 42 + +This is a short-cut to do nothing if the original exit code was already 42. + +=item $$new_exit_code_ref = 42 + +This changes the exit code to 42. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestingDone.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestingDone.pm new file mode 100644 index 000000000000..598abaf037b9 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/TestingDone.pm @@ -0,0 +1,121 @@ +package Test2::Manual::Tooling::Plugin::TestingDone; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Plugin::TestingDone - Run code when the test file is +finished, or when done_testing is called. + +=head1 DESCRIPTION + +This is a way to add behavior to the end of a test file. This code is run +either when done_testing() is called, or when the test file has no more +run-time code to run. + +When triggered by done_testing() this will be run BEFORE the plan is calculated +and sent. This means it IS safe to make test assertions in this callback. + +=head1 COMPLETE CODE UP FRONT + + package Test2::Plugin::MyPlugin; + + use Test2::API qw{test2_add_callback_testing_done}; + + sub import { + my $class = shift; + + test2_add_callback_testing_done(sub { + ok(!$some_global, '$some_global was not set'); + print "The test file is done, or done_testing was just called\n" + }); + } + + 1; + +=head1 LINE BY LINE + +=over 4 + +=item use Test2::API qw{test2_add_callback_testing_done}; + +This imports the C callback. + +=item test2_add_callback_testing_done(sub { ... }); + +This adds our callback to be called when testing is done. + +=item ok(!$some_global, '$some_global was not set') + +It is safe to make assertions in this type of callback. This code simply +asserts that some global was never set over the course of the test. + +=item print "The test file is done, or done_testing was just called\n" + +This prints a message when the callback is run. + +=back + +=head1 UNDER THE HOOD + +Before test2_add_callback_testing_done() this kind of thing was still possible, +but it was hard to get right, here is the code to do it: + + test2_add_callback_post_load(sub { + my $stack = test2_stack(); + + # Insure we have at least one hub, but we do not necessarily want the + # one this returns. + $stack->top; + + # We want the root hub, not the top one. + my ($root) = Test2::API::test2_stack->all; + + # Make sure the hub does not believe nothing has happened. + $root->set_active(1); + + # Now we can add our follow-up code + $root->follow_up(sub { + # Your callback code here + }); + }); + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm new file mode 100644 index 000000000000..abd18b6e955f --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm @@ -0,0 +1,94 @@ +package Test2::Manual::Tooling::Plugin::ToolCompletes; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Plugin::ToolCompletes - How to add behaviors that occur +when a tool completes work. + +=head1 DESCRIPTION + +This tutorial helps you understand how to add behaviors that occur when a tool +is done with its work. All tools need to acquire and then release a context, +for this tutorial we make use of the release hooks that are called every time a +tool releases the context object. + +=head1 COMPLETE CODE UP FRONT + + package Test2::Plugin::MyPlugin; + + use Test2::API qw{test2_add_callback_context_release}; + + sub import { + my $class = shift; + + test2_add_callback_context_release(sub { + my $ctx_ref = shift; + + print "Context was released\n"; + }); + } + + 1; + +=head1 LINE BY LINE + +=over 4 + +=item use Test2::API qw{test2_add_callback_context_release}; + +This imports the C callback. + +=item test2_add_callback_context_release(sub { ... }) + +=item my $ctx_ref = shift + +The coderefs for test2_add_callback_context_release() will receive exactly 1 +argument, the context being released. + +=item print "Context was released\n" + +Print a notification whenever the context is released. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm new file mode 100644 index 000000000000..2654c54a50fd --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm @@ -0,0 +1,126 @@ +package Test2::Manual::Tooling::Plugin::ToolStarts; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Plugin::ToolStarts - How to add behaviors that occur +when a tool starts work. + +=head1 DESCRIPTION + +This tutorial will help you write plugins that have behavior when a tool +starts. All tools should start by acquiring a context object. This tutorial +shows you the hooks you can use to take advantage of the context acquisition. + +=head1 COMPLETE CODE UP FRONT + + package Test2::Plugin::MyPlugin; + + use Test2::API qw{ + test2_add_callback_context_init + test2_add_callback_context_acquire + }; + + sub import { + my $class = shift; + + # Let us know every time a tool requests a context, and give us a + # chance to modify the parameters before we find it. + test2_add_callback_context_acquire(sub { + my $params_ref = shift; + + print "A tool has requested the context\n"; + }); + + # Callback every time a new context is created, not called if an + # existing context is found. + test2_add_callback_context_init(sub { + my $ctx_ref = shift; + + print "A new context was created\n"; + }); + } + + 1; + +=head1 LINE BY LINE + +=over 4 + +=item use Test2::API qw{test2_add_callback_context_init test2_add_callback_context_acquire}; + +This imports the C and +C callbacks. + +=item test2_add_callback_context_acquire(sub { ... }) + +This is where we add our callback for context acquisition. Every time +C is called the callback will be run. + +=item my $params_ref = shift + +In the test2_add_callback_context_acquire() callbacks we get exactly 1 +argument, a reference to the parameters that C will use to find the +context. + +=item print "A tool has requested the context\n" + +Print a notification whenever a tool asks for a context. + +=item test2_add_callback_context_init(sub { ... }) + +Add our context init callback. These callbacks are triggered whenever a +completely new context is created. This is not called if an existing context is +found. In short this only fires off for the top level tool, not nested tools. + +=item my $ctx_ref = shift + +The coderefs for test2_add_callback_context_init() will receive exactly 1 +argument, the newly created context. + +=item print "A new context was created\n" + +Print a notification whenever a new context is created. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Subtest.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Subtest.pm new file mode 100644 index 000000000000..33c5845ac74d --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Subtest.pm @@ -0,0 +1,164 @@ +package Test2::Manual::Tooling::Subtest; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Subtest - How to implement a tool that makes use of +subtests. + +=head1 DESCRIPTION + +Subtests are a nice way of making related events visually, and architecturally +distinct. + +=head1 WHICH TYPE OF SUBTEST DO I NEED? + +There are 2 types of subtest. The first type is subtests with user-supplied +coderefs, such as the C function itself. The second type is subtest +that do not have any user supplied coderefs. + +So which type do you need? The answer to that is simple, if you are going to +let the user define the subtest with their own codeblock, you have the first +type, otherwise you have the second. + +In either case, you will still need use the same API function: +C. + +=head2 SUBTEST WITH USER SUPPLIED CODEREF + +This example will emulate the C function. + + use Test2::API qw/context run_subtest/; + + sub my_subtest { + my ($name, $code) = @_; + + # Like any other tool, you need to acquire a context, if you do not then + # things will not report the correct file and line number. + my $ctx = context(); + + my $bool = run_subtest($name, $code); + + $ctx->release; + + return $bool; + } + +This looks incredibly simple... and it is. C does all the hard +work for you. This will issue an L event with the +results of the subtest. The subtest event itself will report to the proper file +and line number due to the context you acquired (even though it does not I +like you used the context. + +C can take additional arguments: + + run_subtest($name, $code, \%params, @args); + +=over 4 + +=item @args + +This allows you to pass arguments into the codeblock that gets run. + +=item \%params + +This is a hashref of parameters. Currently there are 3 possible parameters: + +=over 4 + +=item buffered => $bool + +This will turn the subtest into the new style buffered subtest. This type of +subtest is recommended, but not default. + +=item inherit_trace => $bool + +This is used for tool-side coderefs. + +=item no_fork => $bool + +react to forking/threading inside the subtest itself. In general you are +unlikely to need/want this parameter. + +=back + +=back + +=head2 SUBTEST WITH TOOL-SIDE CODEREF + +This is particularly useful if you want to turn a tool that wraps other tools +into a subtest. For this we will be using the tool we created in +L. + + use Test2::API qw/context run_subtest/; + + sub check_class { + my $class = shift; + + my $ctx = context(); + + my $code = sub { + my $obj = $class->new; + is($obj->foo, 'foo', "got foo"); + is($obj->bar, 'bar', "got bar"); + }; + + my $bool = run_subtest($class, $code, {buffered => 1, inherit_trace => 1}); + + $ctx->release; + + return $bool; + } + +The C function does all the heavy lifting for us. All we need +to do is give the function a name, a coderef to run, and the +C<< inherit_trace => 1 >> parameter. The C<< buffered => 1 >> parameter is +optional, but recommended. + +The C parameter tells the subtest tool that the contexts acquired +inside the nested tools should use the same trace as the subtest itself. For +user-supplied codeblocks you do not use inherit_trace because you want errors +to report to the user-supplied file+line. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/TestBuilder.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/TestBuilder.pm new file mode 100644 index 000000000000..6537e5521c52 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/TestBuilder.pm @@ -0,0 +1,171 @@ +package Test2::Manual::Tooling::TestBuilder; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::TestBuilder - This section maps Test::Builder methods +to Test2 concepts. + +=head1 DESCRIPTION + +With Test::Builder tools were encouraged to use methods on the Test::Builder +singleton object. Test2 has a different approach, every tool should get a new +L object, and call methods on that. This document maps +several concepts from Test::Builder to Test2. + +=head1 CONTEXT + +First thing to do, stop using the Test::Builder singleton, in fact stop using +or even loading Test::Builder. Instead of Test::Builder each tool you write +should follow this template: + + use Test2::API qw/context/; + + sub my_tool { + my $ctx = context(); + + ... do work ... + + $ctx->ok(1, "a passing assertion"); + + $ctx->release; + + return $whatever; + } + +The original Test::Builder style was this: + + use Test::Builder; + my $tb = Test::Builder->new; # gets the singleton + + sub my_tool { + ... do work ... + + $tb->ok(1, "a passing assertion"); + + return $whatever; + } + +=head1 TEST BUILDER METHODS + +=over 4 + +=item $tb->BAIL_OUT($reason) + +The context object has a 'bail' method: + + $ctx->bail($reason) + +=item $tb->diag($string) + +=item $tb->note($string) + +The context object has diag and note methods: + + $ctx->diag($string); + $ctx->note($string); + +=item $tb->done_testing + +The context object has a done_testing method: + + $ctx->done_testing; + +Unlike the Test::Builder version, no arguments are allowed. + +=item $tb->like + +=item $tb->unlike + +These are not part of context, instead look at L and +L. + +=item $tb->ok($bool, $name) + + # Preferred + $ctx->pass($name); + $ctx->fail($name, @diag); + + # Discouraged, but supported: + $ctx->ok($bool, $name, \@failure_diags) + +=item $tb->subtest + +use the C function instead. See L for documentation. + +=item $tb->todo_start + +=item $tb->todo_end + +See L instead. + +=item $tb->output, $tb->failure_output, and $tb->todo_output + +These are handled via formatters now. See L and +L. + +=back + +=head1 LEVEL + +L had the C<$Test::Builder::Level> variable that you could +modify in order to set the stack depth. This was useful if you needed to nest +tools and wanted to make sure your file and line number were correct. It was +also frustrating and prone to errors. Some people never even discovered the +level variable and always had incorrect line numbers when their tools would +fail. + +L uses the context system, which solves the problem a better way. The +top-most tool get a context, and holds on to it until it is done. Any tool +nested under the first will find and use the original context instead of +generating a new one. This means the level problem is solved for free, no +variables to mess with. + +L is also smart enough to honor c<$Test::Builder::Level> if it is set. + +=head1 TODO + +L used the C<$TODO> package variable to set the TODO state. This +was confusing, and easy to get wrong. See L for the modern +way to accomplish a TODO state. + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Testing.pm b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Testing.pm new file mode 100644 index 000000000000..e6fd05910388 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Manual/Tooling/Testing.pm @@ -0,0 +1,151 @@ +package Test2::Manual::Tooling::Testing; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=head1 NAME + +Test2::Manual::Tooling::Testing - Tutorial on how to test your testing tools. + +=head1 DESCRIPTION + +Testing your test tools used to be a complex and difficult prospect. The old +tools such as L and L were limited, and +fragile. Test2 on the other hand was designed from the very start to be easily +tested! This tutorial shows you how. + +=head1 THE HOLY GRAIL OF TESTING YOUR TOOLS + +The key to making Test2 easily testable (specially when compared to +Test::Builder) is the C function. + + use Test2::API qw/intercept/; + + my $events = intercept { + ok(1, "pass"); + ok(0, "fail"); + + diag("A diag"); + }; + +The intercept function lets you use any test tools you want inside a codeblock. +No events or contexts generated within the intercept codeblock will have any +effect on the outside testing state. The C function completely +isolates the tools called within. + +B Plugins and things that effect global API state may not be fully +isolated. C is intended specifically for event isolation. + +The C function will return an arrayref containing all the events +that were generated within the codeblock. You can now make any assertions you +want about the events you expected your tools to generate. + + [ + bless({...}, 'Test2::Event::Ok'), # pass + bless({...}, 'Test2::Event::Ok'), # fail + bless({...}, 'Test2::Event::Diag'), # Failure diagnostics (not always a second event) + bless({...}, 'Test2::Event::Diag'), # custom 'A diag' message + ] + +Most test tools eventually produce one or more events. To effectively verify +the events you get from intercept you really should read up on how events work +L. Once you know about events you can move on to +the next section which points you at some helpers. + +=head1 ADDITIONAL HELPERS + +=head2 Test2::Tools::Tester + +This is the most recent set of tools to help you test your events. To really +understand these you should familiarize yourself with +L. If you are going to be writing anything more +than the most simple of tools you should know how events work. + +The L documentation is a good place for further reading. + +=head2 Test2::Tools::HarnessTester + +The L can export the C tool. +This tool lets you run your event arrayref through L so that you +can get a pass/fail summary. + + my $summary = summarize_events($events); + +The summary looks like this: + + { + plan => $plan_facet, # the plan event facet + pass => $bool, # true if the events result in a pass + fail => $bool, # true if the events result in a fail + errors => $error_count, # Number of error facets seen + failures => $failure_count, # Number of failing assertions seen + assertions => $assertion_count, # Total number of assertions seen + } + +=head2 Test2::Tools::Compare + +B These tools were written before the switch to faceted events. +These will still work, but are no longer the recommended way to test your +tools. + +The L library exports a handful of extras to help test +events. + +=over 4 + +=item event $TYPE => ... + +Use in an array check against $events to check for a specific type of event +with the properties you specify. + +=item fail_events $TYPE => ... + +Use when you expect a failing assertion of $TYPE. This will automatically check +that the next event following it is a diagnostics message with the default +failure text. + +B This is outdated as a single event may now possess both the failing +assertion AND the failing text, such events will fail this test. + +=back + +=head1 SEE ALSO + +L - Primary index of the manual. + +=head1 SOURCE + +The source code repository for Test2-Manual 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 2018 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/cpan/Test2-Suite/lib/Test2/Mock.pm b/cpan/Test2-Suite/lib/Test2/Mock.pm new file mode 100644 index 000000000000..831122dd0cac --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Mock.pm @@ -0,0 +1,897 @@ +package Test2::Mock; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak confess/; +our @CARP_NOT = (__PACKAGE__); + +use Scalar::Util qw/weaken reftype blessed/; +use Test2::Util qw/pkg_to_file/; +use Test2::Util::Stash qw/parse_symbol slot_to_sig get_symbol get_stash purge_symbol/; +use Test2::Util::Sub qw/gen_accessor gen_reader gen_writer/; + +sub new; # Prevent hashbase from giving us 'new'; +use Test2::Util::HashBase qw/class parent child _purge_on_destroy _blocked_load _symbols _track sub_tracking call_tracking/; + +sub new { + my $class = shift; + + croak "Called new() on a blessed instance, did you mean to call \$control->class->new()?" + if blessed($class); + + my $self = bless({}, $class); + + $self->{+SUB_TRACKING} ||= {}; + $self->{+CALL_TRACKING} ||= []; + + my @sets; + while (my $arg = shift @_) { + my $val = shift @_; + + if ($class->can(uc($arg))) { + $self->{$arg} = $val; + next; + } + + push @sets => [$arg, $val]; + } + + croak "The 'class' field is required" + unless $self->{+CLASS}; + + for my $set (@sets) { + my ($meth, $val) = @$set; + my $type = reftype($val); + + confess "'$meth' is not a valid constructor argument for $class" + unless $self->can($meth); + + if (!$type) { + $self->$meth($val); + } + elsif($type eq 'HASH') { + $self->$meth(%$val); + } + elsif($type eq 'ARRAY') { + $self->$meth(@$val); + } + else { + croak "'$val' is not a valid argument for '$meth'" + } + } + + return $self; +} + +sub _check { + return unless $_[0]->{+CHILD}; + croak "There is an active child controller, cannot proceed"; +} + +sub purge_on_destroy { + my $self = shift; + ($self->{+_PURGE_ON_DESTROY}) = @_ if @_; + return $self->{+_PURGE_ON_DESTROY}; +} + +sub stash { + my $self = shift; + get_stash($self->{+CLASS}); +} + +sub file { + my $self = shift; + my $file = $self->class; + return pkg_to_file($self->class); +} + +sub block_load { + my $self = shift; + $self->_check(); + + my $file = $self->file; + + croak "Cannot block the loading of module '" . $self->class . "', already loaded in file $INC{$file}" + if $INC{$file}; + + $INC{$file} = __FILE__; + + $self->{+_BLOCKED_LOAD} = 1; +} + +my %NEW = ( + hash => sub { + my ($class, %params) = @_; + return bless \%params, $class; + }, + array => sub { + my ($class, @params) = @_; + return bless \@params, $class; + }, + ref => sub { + my ($class, $params) = @_; + return bless $params, $class; + }, + ref_copy => sub { + my ($class, $params) = @_; + my $type = reftype($params); + + return bless {%$params}, $class + if $type eq 'HASH'; + + return bless [@$params], $class + if $type eq 'ARRAY'; + + croak "Not sure how to construct an '$class' from '$params'"; + }, +); + +sub override_constructor { + my $self = shift; + my ($name, $type) = @_; + $self->_check(); + + my $sub = $NEW{$type} + || croak "'$type' is not a known constructor type"; + + $self->override($name => $sub); +} + +sub add_constructor { + my $self = shift; + my ($name, $type) = @_; + $self->_check(); + + my $sub = $NEW{$type} + || croak "'$type' is not a known constructor type"; + + $self->add($name => $sub); +} + +sub autoload { + my $self = shift; + $self->_check(); + my $class = $self->class; + my $stash = $self->stash; + + croak "Class '$class' already has an AUTOLOAD" + if $stash->{AUTOLOAD} && *{$stash->{AUTOLOAD}}{CODE}; + croak "Class '$class' already has an can" + if $stash->{can} && *{$stash->{can}}{CODE}; + + # Weaken this reference so that AUTOLOAD does not prevent its own + # destruction. + weaken(my $c = $self); + + my ($file, $line) = (__FILE__, __LINE__ + 3); + my $autoload = eval <{\$name}) = \@_ if \@_; + return \$self->{\$name}; + }; + + \$c->add(\$name => \$sub); + + if (\$c->{_track}) { + my \$call = {sub_name => \$name, sub_ref => \$sub, args => [\@_]}; + push \@{\$c->{sub_tracking}->{\$name}} => \$call; + push \@{\$c->{call_tracking}} => \$call; + } + + goto &\$sub; + } +EOT + + $line = __LINE__ + 3; + my $can = eval <SUPER::can(\$meth)) { + return \$self->SUPER::can(\$meth); + } + elsif (ref \$self && reftype \$self eq 'HASH' && exists \$self->{\$meth}) { + return sub { shift->\$meth(\@_) }; + } + return undef; + } +EOT + + { + local $self->{+_TRACK} = 0; + $self->add(AUTOLOAD => $autoload); + $self->add(can => $can); + } +} + +sub before { + my $self = shift; + my ($name, $sub) = @_; + $self->_check(); + my $orig = $self->current($name); + $self->_inject({}, $name => sub { $sub->(@_); $orig->(@_) }); +} + +sub after { + my $self = shift; + my ($name, $sub) = @_; + $self->_check(); + my $orig = $self->current($name); + $self->_inject({}, $name => sub { + my @out; + + my $want = wantarray; + + if ($want) { + @out = $orig->(@_); + } + elsif(defined $want) { + $out[0] = $orig->(@_); + } + else { + $orig->(@_); + } + + $sub->(@_); + + return @out if $want; + return $out[0] if defined $want; + return; + }); +} + +sub around { + my $self = shift; + my ($name, $sub) = @_; + $self->_check(); + my $orig = $self->current($name); + $self->_inject({}, $name => sub { $sub->($orig, @_) }); +} + +sub add { + my $self = shift; + $self->_check(); + $self->_inject({add => 1}, @_); +} + +sub override { + my $self = shift; + $self->_check(); + $self->_inject({}, @_); +} + +sub set { + my $self = shift; + $self->_check(); + $self->_inject({set => 1}, @_); +} + +sub current { + my $self = shift; + my ($sym) = @_; + + return get_symbol($sym, $self->{+CLASS}); +} + +sub orig { + my $self = shift; + my ($sym) = @_; + + $sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/; + + my $syms = $self->{+_SYMBOLS} + or croak "No symbols have been mocked yet"; + + my $ref = $syms->{$sym}; + + croak "Symbol '$sym' is not mocked" + unless $ref && @$ref; + + my ($orig) = @$ref; + + return $orig; +} + +sub track { + my $self = shift; + + ($self->{+_TRACK}) = @_ if @_; + + return $self->{+_TRACK}; +} + +sub clear_call_tracking { @{shift->{+CALL_TRACKING}} = () } + +sub clear_sub_tracking { + my $self = shift; + + unless (@_) { + %{$self->{+SUB_TRACKING}} = (); + return; + } + + for my $item (@_) { + delete $self->{+SUB_TRACKING}->{$item}; + } + + return; +} + +sub _parse_inject { + my $self = shift; + my ($param, $arg) = @_; + + if ($param =~ m/^-(.*)$/) { + my $sym = $1; + my $sig = slot_to_sig(reftype($arg)); + my $ref = $arg; + return ($sig, $sym, $ref); + } + + return ('&', $param, $arg) + if ref($arg) && reftype($arg) eq 'CODE'; + + my ($is, $field, $val); + + if(defined($arg) && !ref($arg) && $arg =~ m/^(rw|ro|wo)$/) { + $is = $arg; + $field = $param; + } + elsif (!ref($arg)) { + $val = $arg; + $is = 'val'; + } + elsif (reftype($arg) eq 'HASH') { + $field = delete $arg->{field} || $param; + + $val = delete $arg->{val}; + $is = delete $arg->{is}; + + croak "Cannot specify 'is' and 'val' together" if $val && $is; + + $is ||= $val ? 'val' : 'rw'; + + croak "The following keys are not valid when defining a mocked sub with a hashref: " . join(", " => keys %$arg) + if keys %$arg; + } + else { + confess "'$arg' is not a valid argument when defining a mocked sub"; + } + + my $sub; + if ($is eq 'rw') { + $sub = gen_accessor($field); + } + elsif ($is eq 'ro') { + $sub = gen_reader($field); + } + elsif ($is eq 'wo') { + $sub = gen_writer($field); + } + else { # val + $sub = sub { $val }; + } + + return ('&', $param, $sub); +} + +sub _inject { + my $self = shift; + my ($params, @pairs) = @_; + + my $add = $params->{add}; + my $set = $params->{set}; + + my $class = $self->{+CLASS}; + + $self->{+_SYMBOLS} ||= {}; + my $syms = $self->{+_SYMBOLS}; + + while (my $param = shift @pairs) { + my $arg = shift @pairs; + my ($sig, $sym, $ref) = $self->_parse_inject($param, $arg); + my $orig = $self->current("$sig$sym"); + + croak "Cannot override '$sig$class\::$sym', symbol is not already defined" + unless $orig || $add || $set || ($sig eq '&' && $class->can($sym)); + + # Cannot be too sure about scalars in globs + croak "Cannot add '$sig$class\::$sym', symbol is already defined" + if $add && $orig + && (reftype($orig) ne 'SCALAR' || defined($$orig)); + + $syms->{"$sig$sym"} ||= []; + push @{$syms->{"$sig$sym"}} => $orig; # Might be undef, thats expected + + if ($self->{+_TRACK} && $sig eq '&') { + my $sub_tracker = $self->{+SUB_TRACKING}; + my $call_tracker = $self->{+CALL_TRACKING}; + my $sub = $ref; + $ref = sub { + my $call = {sub_name => $sym, sub_ref => $sub, args => [@_]}; + push @{$sub_tracker->{$param}} => $call; + push @$call_tracker => $call; + goto &$sub; + }; + } + + no strict 'refs'; + no warnings 'redefine'; + *{"$class\::$sym"} = $ref; + } + + return; +} + +sub _set_or_unset { + my $self = shift; + my ($symbol, $set) = @_; + + my $class = $self->{+CLASS}; + + return purge_symbol($symbol, $class) + unless $set; + + my $sym = parse_symbol($symbol, $class); + no strict 'refs'; + no warnings 'redefine'; + *{"$class\::$sym->{name}"} = $set; +} + +sub restore { + my $self = shift; + my ($sym) = @_; + $self->_check(); + + $sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/; + + my $syms = $self->{+_SYMBOLS} + or croak "No symbols are mocked"; + + my $ref = $syms->{$sym}; + + croak "Symbol '$sym' is not mocked" + unless $ref && @$ref; + + my $old = pop @$ref; + delete $syms->{$sym} unless @$ref; + + return $self->_set_or_unset($sym, $old); +} + +sub reset { + my $self = shift; + my ($sym) = @_; + $self->_check(); + + $sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/; + + my $syms = $self->{+_SYMBOLS} + or croak "No symbols are mocked"; + + my $ref = delete $syms->{$sym}; + + croak "Symbol '$sym' is not mocked" + unless $ref && @$ref; + + my ($old) = @$ref; + + return $self->_set_or_unset($sym, $old); +} + +sub reset_all { + my $self = shift; + $self->_check(); + + my $syms = $self->{+_SYMBOLS} || return; + + $self->reset($_) for keys %$syms; + + delete $self->{+_SYMBOLS}; +} + +sub _purge { + my $self = shift; + my $stash = $self->stash; + delete $stash->{$_} for keys %$stash; +} + +sub DESTROY { + my $self = shift; + + delete $self->{+CHILD}; + $self->reset_all if $self->{+_SYMBOLS}; + + delete $INC{$self->file} if $self->{+_BLOCKED_LOAD}; + + $self->_purge if $self->{+_PURGE_ON_DESTROY}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Mock - Module for managing mocked classes and instances. + +=head1 DESCRIPTION + +This module lets you add and override methods for any package temporarily. When +the instance is destroyed it will restore the package to its original state. + +=head1 SYNOPSIS + + use Test2::Mock; + use MyClass; + + my $mock = Test2::Mock->new( + track => $BOOL, # enable call tracking if desired + class => 'MyClass', + override => [ + name => sub { 'fred' }, + ... + ], + add => [ + is_mocked => sub { 1 } + ... + ], + ... + ); + + # Unmock the 'name' sub + $mock->restore('name'); + + ... + + $mock = undef; # Will remove all the mocking + +=head1 CONSTRUCTION + +=head1 METHODS + +=over 4 + +=item $mock = Test2::Mock->new(class => $CLASS, ...) + +This will create a new instance of L that manages mocking +for the specified C<$CLASS>. + +Any C method can be used as a constructor argument, each +should be followed by an arrayref of arguments to be used within the method. For +instance the C method: + + my $mock = Test2::Mock->new( + class => 'AClass', + add => [foo => sub { 'foo' }], + ); + +is identical to this: + + my $mock = Test2::Mock->new( + class => 'AClass', + ); + $mock->add(foo => sub { 'foo' }); + +=item $mock->track($bool) + +Turn tracking on or off. Any sub added/overridden/set when tracking is on will +log every call in a hash retrievable via C<< $mock->tracking >>. Changing the +tracking toggle will not affect subs already altered, but will affect any +additional alterations. + +=item $hashref = $mock->sub_tracking + +The tracking data looks like this: + + { + sub_name => [ + {sub_name => $sub_name, sub_ref => $mock_subref, args => [... copy of @_ from the call ... ]}, + ..., + ..., + ], + } + +Unlike call_tracking, this lists all calls by sub, so you can choose to only +look at the sub specific calls. + +B The hashref items with the subname and args are shared with +call_tracking, modifying one modifies the other, so copy first! + +=item $arrayref = $mock->call_tracking + +The tracking data looks like this: + + [ + {sub_name => $sub_name, sub_ref => $mock_subref, args => [... copy of @_ from the call ... ]}, + ..., + ..., + ] + +Unlike sub_tracking this lists all calls to any mocked sub, in the order they +were called. To filter by sub use sub_tracking. + +B The hashref items with the subname and args are shared with +sub_tracking, modifying one modifies the other, so copy first! + +=item $mock->clear_sub_tracking() + +=item $mock->clear_sub_tracking(\@subnames) + +Clear tracking data. With no arguments ALL tracking data is cleared. When +arguments are provided then only those specific keys will be cleared. + +=item $mock->clear_call_tracking() + +Clear all items from call_tracking. + +=item $mock->add('symbol' => ..., 'symbol2' => ...) + +=item $mock->override('symbol1' => ..., 'symbol2' => ...) + +=item $mock->set('symbol1' => ..., 'symbol2' => ...) + +C and C are the primary ways to add/modify methods for a +class. Both accept the exact same type of arguments. The difference is that +C will fail unless the symbol you are overriding already exists, +C on the other hand will fail if the symbol does already exist. + +C was more recently added for cases where you may not know if the sub +already exists. These cases are rare, and set should be avoided (think of it +like 'no strict'). However there are valid use cases, so it was added. + +B Think of override as a push operation. If you call override on the +same symbol multiple times it will track that. You can use C as a +pop operation to go back to the previous mock. C can be used to remove +all the mocking for a symbol. + +Arguments must be a symbol name, with optional sigil, followed by a new +specification of the symbol. If no sigil is specified then '&' (sub) is +assumed. A simple example of overriding a sub: + + $mock->override(foo => sub { 'overridden foo' }); + my $val = $class->foo; # Runs our override + # $val is now set to 'overridden foo' + +You can also simply provide a value and it will be wrapped in a sub for you: + + $mock->override( foo => 'foo' ); + +The example above will generate a sub that always returns the string 'foo'. + +There are three *special* values that can be used to generate accessors: + + $mock->add( + name => 'rw', # Generates a read/write accessor + age => 'ro', # Generates a read only accessor + size => 'wo', # Generates a write only accessor + ); + +If you want to have a sub that actually returns one of the three special strings, or +that returns a coderef, you can use a hashref as the spec: + + my $ref = sub { 'my sub' }; + $mock->add( + rw_string => { val => 'rw' }, + ro_string => { val => 'ro' }, + wo_string => { val => 'wo' }, + coderef => { val => $ref }, # the coderef method returns $ref each time + ); + +You can also override/add other symbol types, such as hash: + + package Foo; + ... + + $mock->add('%foo' => {a => 1}); + + print $Foo::foo{a}; # prints '1' + +You can also tell mock to deduce the symbol type for the add/override from the +reference, rules are similar to glob assignments: + + $mock->add( + -foo => sub { 'foo' }, # Adds the &foo sub to the package + -foo => { foo => 1 }, # Adds the %foo hash to the package + -foo => [ 'f', 'o', 'o' ], # Adds the @foo array to the package + -foo => \"foo", # Adds the $foo scalar to the package + ); + +=item $mock->restore($SYMBOL) + +Restore the symbol to what it was before the last override. If the symbol was +recently added this will remove it. If the symbol has been overridden multiple +times this will ONLY restore it to the previous state. Think of C as a +push operation, and C as the pop operation. + +=item $mock->reset($SYMBOL) + +Remove all mocking of the symbol and restore the original symbol. If the symbol +was initially added then it will be completely removed. + +=item $mock->orig($SYMBOL) + +This will return the original symbol, before any mocking. For symbols that were +added this will return undef. + +=item $mock->current($SYMBOL) + +This will return the current symbol. + +=item $mock->reset_all + +Remove all added symbols, and restore all overridden symbols to their originals. + +=item $mock->add_constructor($NAME => $TYPE) + +=item $mock->override_constructor($NAME => $TYPE) + +This can be used to inject constructors. The first argument should be the name +of the constructor. The second argument specifies the constructor type. + +The C type is the most common, all arguments are used to create a new +hash that is blessed. + + hash => sub { + my ($class, %params) = @_; + return bless \%params, $class; + }; + +The C type is similar to the hash type, but accepts a list instead of +key/value pairs: + + array => sub { + my ($class, @params) = @_; + return bless \@params, $class; + }; + +The C type takes a reference and blesses it. This will modify your +original input argument. + + ref => sub { + my ($class, $params) = @_; + return bless $params, $class; + }; + +The C type will copy your reference and bless the copy: + + ref_copy => sub { + my ($class, $params) = @_; + my $type = reftype($params); + + return bless {%$params}, $class + if $type eq 'HASH'; + + return bless [@$params], $class + if $type eq 'ARRAY'; + + croak "Not sure how to construct a '$class' from '$params'"; + }; + +=item $mock->before($NAME, sub { ... }) + +This will replace the original sub C<$NAME> with a new sub that calls your +custom code just before calling the original method. The return from your +custom sub is ignored. Your sub and the original both get the unmodified +arguments. + +=item $mock->after($NAME, sub { ... }) + +This is similar to before, except your callback runs after the original code. +The return from your callback is ignored. + +=item $mock->around($NAME, sub { ... }) + +This gives you the chance to wrap the original sub: + + $mock->around(foo => sub { + my $orig = shift; + my $self = shift; + my (@args) = @_; + + ... + $self->$orig(@args); + ... + + return ...; + }); + +The original sub is passed in as the first argument, even before C<$self>. You +are responsible for making sure your wrapper sub returns the correct thing. + +=item $mock->autoload + +This will inject an C sub into the class. This autoload will +automatically generate read-write accessors for any sub called that does not +already exist. + +=item $mock->block_load + +This will prevent the real class from loading until the mock is destroyed. This +will fail if the class is already loaded. This will let you mock a class +completely without loading the original module. + +=item $pm_file = $mock->file + +This returns the relative path to the file for the module. This corresponds to +the C<%INC> entry. + +=item $bool = $mock->purge_on_destroy($bool) + +When true, this will cause the package stash to be completely obliterated when +the mock object falls out of scope or is otherwise destroyed. You do not +normally want this. + +=item $stash = $mock->stash + +This returns the stash for the class being mocked. This is the equivalent of: + + my $stash = \%{"${class}\::"}; + +This saves you from needing to turn off strict. + +=item $class = $mock->class + +The class being mocked by this instance. + +=item $p = $mock->parent + +If you mock a class twice the first instance is the parent, the second is the +child. This prevents the parent from being destroyed before the child, which +would lead to a very unpleasant situation. + +=item $c = $mock->child + +Returns the child mock, if any. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +L. + +=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 2018 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 L + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/Plugin.pm b/cpan/Test2-Suite/lib/Test2/Plugin.pm new file mode 100644 index 000000000000..4af7de4c1d4a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Plugin.pm @@ -0,0 +1,81 @@ +package Test2::Plugin; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin - Documentation for plugins + +=head1 DESCRIPTION + +Plugins are packages that cause behavior changes, or other side effects for the +test file that loads them. They should not export any functions, or provide any +tools. Plugins should be distinct units of functionality. + +If you wish to combine behavior changes with tools then you should write a +Plugin, a Tools module, and a bundle that loads them both. + +=head1 FAQ + +=over 4 + +=item Should I subclass Test2::Plugin? + +No. Currently this class is empty. Eventually we may want to add behavior, in +which case we do not want anyone to already be subclassing it. + +=back + +=head1 HOW DO I WRITE A PLUGIN? + +Writing a plugin is not as simple as writing an L, or writing +L. Plugins alter behavior, or cause desirable side-effects. To +accomplish this you typically need a custom C method that calls one +or more functions provided by the L package. + +If you want to write a plugin you should look at existing plugins, as well as +the L and L documentation. There is no formula for a +Plugin, they are generally unique, however consistent rules are that they +should not load other plugins, or export any functions. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Plugin/BailOnFail.pm b/cpan/Test2-Suite/lib/Test2/Plugin/BailOnFail.pm new file mode 100644 index 000000000000..88378a9a9487 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Plugin/BailOnFail.pm @@ -0,0 +1,80 @@ +package Test2::Plugin::BailOnFail; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API qw/test2_add_callback_context_release/; + +my $LOADED = 0; +sub import { + return if $LOADED++; + + test2_add_callback_context_release(sub { + my $ctx = shift; + return if $ctx->hub->is_passing; + $ctx->bail("(Bail On Fail)"); + }); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin::BailOnFail - Automatically bail out of testing on the first test +failure. + +=head1 DESCRIPTION + +This module will issue a bailout event after the first test failure. This will +prevent your tests from continuing. The bailout runs when the context is +released; that is, it will run when the test function you are using, such as +C, returns. This gives the tools the ability to output any extra +diagnostics they may need. + +=head1 SYNOPSIS + + use Test2::V0; + use Test2::Plugin::BailOnFail; + + ok(1, "pass"); + ok(0, "fail"); + ok(1, "Will not run"); + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Plugin/DieOnFail.pm b/cpan/Test2-Suite/lib/Test2/Plugin/DieOnFail.pm new file mode 100644 index 000000000000..a6b17e5ecbe2 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Plugin/DieOnFail.pm @@ -0,0 +1,78 @@ +package Test2::Plugin::DieOnFail; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API qw/test2_add_callback_context_release/; + +my $LOADED = 0; +sub import { + return if $LOADED++; + + test2_add_callback_context_release(sub { + my $ctx = shift; + return if $ctx->hub->is_passing; + $ctx->throw("(Die On Fail)"); + }); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin::DieOnFail - Automatically die on the first test failure. + +=head1 DESCRIPTION + +This module will die after the first test failure. This will prevent your tests +from continuing. The exception is thrown when the context is released, that is +it will run when the test function you are using, such as C, returns. +This gives the tools the ability to output any extra diagnostics they may need. + +=head1 SYNOPSIS + + use Test2::V0; + use Test2::Plugin::DieOnFail; + + ok(1, "pass"); + ok(0, "fail"); + ok(1, "Will not run"); + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Plugin/ExitSummary.pm b/cpan/Test2-Suite/lib/Test2/Plugin/ExitSummary.pm new file mode 100644 index 000000000000..fa048ab86bf0 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Plugin/ExitSummary.pm @@ -0,0 +1,90 @@ +package Test2::Plugin::ExitSummary; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API qw/test2_add_callback_exit/; + +my $ADDED_HOOK = 0; +sub import { test2_add_callback_exit(\&summary) unless $ADDED_HOOK++ } + +sub active { $ADDED_HOOK } + +sub summary { + my ($ctx, $real, $new) = @_; + + # Avoid double-printing diagnostics if Test::Builder already loaded. + return if $INC{'Test/Builder.pm'}; + + my $hub = $ctx->hub; + my $plan = $hub->plan; + my $count = $hub->count; + my $failed = $hub->failed; + + $ctx->diag('No tests run!') if !$count && (!$plan || $plan ne 'SKIP'); + $ctx->diag('Tests were run but no plan was declared and done_testing() was not seen.') + if $count && !$plan; + + $ctx->diag("Looks like your test exited with $real after test #$count.") + if $real; + + $ctx->diag("Did not follow plan: expected $plan, ran $count.") + if $plan && $plan =~ m/^[0-9]+$/ && defined $count && $count != $plan; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin::ExitSummary - Add extra diagnostics on failure at the end of the +test. + +=head1 DESCRIPTION + +This will provide some diagnostics after a failed test. These diagnostics can +range from telling you how you deviated from your plan, warning you if there +was no plan, etc. People used to L generally expect these +diagnostics. + +=head1 SYNOPSIS + + use Test2::Plugin::ExitSummary; + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Plugin/SRand.pm b/cpan/Test2-Suite/lib/Test2/Plugin/SRand.pm new file mode 100644 index 000000000000..85e179e46659 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Plugin/SRand.pm @@ -0,0 +1,161 @@ +package Test2::Plugin::SRand; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/carp/; + +use Test2::API qw{ + context + test2_add_callback_post_load + test2_add_callback_exit + test2_stack +}; + +my $ADDED_HOOK = 0; +my $SEED; +my $FROM; + +sub seed { $SEED } +sub from { $FROM } + +sub import { + my $class = shift; + + carp "SRand loaded multiple times, re-seeding rand" + if defined $SEED; + + if (@_ == 1) { + ($SEED) = @_; + $FROM = 'import arg'; + } + elsif (@_ == 2 and $_[0] eq 'seed') { + $SEED = $_[1]; + $FROM = 'import arg'; + } + elsif(exists $ENV{T2_RAND_SEED}) { + $SEED = $ENV{T2_RAND_SEED}; + $FROM = 'environment variable'; + } + else { + my @ltime = localtime; + # Yes, this would be an awful seed if you actually wanted randomness. + # The idea here is that we want "random" behavior to be predictable + # within a given day. This allows you to reproduce failures that may or + # may not happen due to randomness. + $SEED = sprintf('%04d%02d%02d', 1900 + $ltime[5], 1 + $ltime[4], $ltime[3]); + $FROM = 'local date'; + } + + $SEED = 0 unless $SEED; + srand($SEED); + + if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) { + # If the harness is verbose then just display the message for all to + # see. It is nice info and they already asked for noisy output. + + test2_add_callback_post_load(sub { + test2_stack()->top; # Ensure we have at least 1 hub. + my ($hub) = test2_stack()->all; + $hub->send( + Test2::Event::Note->new( + trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'SRAND']), + message => "Seeded srand with seed '$SEED' from $FROM.", + ) + ); + }); + } + elsif (!$ADDED_HOOK++) { + # The seed can be important for debugging, so if anything is wrong we + # should output the seed message as a diagnostics message. This must be + # done at the very end, even later than a hub hook. + test2_add_callback_exit( + sub { + my ($ctx, $real, $new) = @_; + + $ctx->diag("Seeded srand with seed '$SEED' from $FROM.") + if $real + || ($new && $$new) + || !$ctx->hub->is_passing; + } + ); + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin::SRand - Control the random seed for more controlled test +environments. + +=head1 DESCRIPTION + +This module gives you control over the random seed used for your unit tests. In +some testing environments the random seed can play a major role in results. + +The default configuration for this module will seed srand with the local date. +Using the date as the seed means that on any given day the random seed will +always be the same, this means behavior will not change from run to run on a +given day. However the seed is different on different days allowing you to be +sure the code still works with actual randomness. + +The seed is printed for you on failure, or when the harness is verbose. You can +use the C environment variable to specify the seed. You can also +provide a specific seed as a load-time argument to the plugin. + +=head1 SYNOPSIS + +Loading the plugin is easy, and the defaults are sane: + + use Test2::Plugin::SRand; + +Custom seed: + + use Test2::Plugin::SRand seed => 42; + +=head1 NOTE ON LOAD ORDER + +If you use this plugin you probably want to use it as the first, or near-first +plugin. C is not called until the plugin is loaded, so other plugins +loaded first may already be making use of random numbers before your seed +takes effect. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Plugin/Times.pm b/cpan/Test2-Suite/lib/Test2/Plugin/Times.pm new file mode 100644 index 000000000000..44cd285fd3a9 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Plugin/Times.pm @@ -0,0 +1,129 @@ +package Test2::Plugin::Times; +use strict; +use warnings; + +use Test2::Util::Times qw/render_bench render_duration/; + +use Test2::API qw{ + test2_add_callback_exit +}; + +use Time::HiRes qw/time/; + +our $VERSION = '0.000156'; + +my $ADDED_HOOK = 0; +my $START; +sub import { + return if $ADDED_HOOK++; + + $START = time; + test2_add_callback_exit(\&send_time_event); +} + +sub send_time_event { + my ($ctx, $real, $new) = @_; + my $stop = time; + my @times = times(); + + my $summary = render_bench($START, $stop, @times); + my $duration = render_duration($START, $stop); + + my $e = $ctx->send_ev2( + about => {package => __PACKAGE__, details => $summary}, + info => [{tag => 'TIME', details => $summary}], + times => { + details => $summary, + start => $START, + stop => $stop, + user => $times[0], + sys => $times[1], + cuser => $times[2], + csys => $times[3], + }, + harness_job_fields => [ + {name => "time_duration", details => $duration}, + {name => "time_user", details => $times[0]}, + {name => "time_sys", details => $times[1]}, + {name => "time_cuser", details => $times[2]}, + {name => "time_csys", details => $times[3]}, + ], + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin::Times - Output timing data at the end of the test. + +=head1 CAVEAT + +It is important to note that this timing data does not include global +destruction. This data is only collected up until the point done_testing() is +called. If your program takes time for END blocks, garbage collection, and +similar, then this timing data will fall short of reality. + +=head1 DESCRIPTION + +This plugin will output a diagnostics message at the end of testing that tells +you how much time elapsed, and how hard the system worked on the test. + +This will produce a string like one of these (Note these numbers are completely +made up). I + + 0.12345s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 11.1234s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 01m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 04d:18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + +=head1 SYNOPSIS + + use Test2::Plugin::Times; + +This is also useful at the command line for 1-time use: + + $ perl -MTest2::Plugin::Times path/to/test.t + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Plugin/UTF8.pm b/cpan/Test2-Suite/lib/Test2/Plugin/UTF8.pm new file mode 100644 index 000000000000..de3174022ce2 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Plugin/UTF8.pm @@ -0,0 +1,132 @@ +package Test2::Plugin::UTF8; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; + +use Test2::API qw{ + test2_add_callback_post_load + test2_stack +}; + +my $LOADED = 0; + +sub import { + my $class = shift; + + my $import_utf8 = 1; + while ( my $arg = shift @_ ) { + croak "Unsupported import argument '$arg'" unless $arg eq 'encoding_only'; + $import_utf8 = 0; + } + + # Load and import UTF8 into the caller. + if ( $import_utf8 ) { + require utf8; + utf8->import; + } + + return if $LOADED++; # do not add multiple hooks + + # Set the output formatters to use utf8 + test2_add_callback_post_load(sub { + my $stack = test2_stack; + $stack->top; # Make sure we have at least 1 hub + + my $warned = 0; + for my $hub ($stack->all) { + my $format = $hub->format || next; + + unless ($format->can('encoding')) { + warn "Could not apply UTF8 to unknown formatter ($format)\n" unless $warned++; + next; + } + + $format->encoding('utf8'); + } + }); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Plugin::UTF8 - Test2 plugin to test with utf8. + +=head1 DESCRIPTION + +When used, this plugin will make tests work with utf8. This includes +turning on the utf8 pragma and updating the Test2 output formatter to +use utf8. + +=head1 SYNOPSIS + + use Test2::Plugin::UTF8; + +This is similar to: + + use utf8; + BEGIN { + require Test2::Tools::Encoding; + Test2::Tools::Encoding::set_encoding('utf8'); + } + +You can also disable the utf8 import by using 'encoding_only' to only enable +utf8 encoding on the output format. + + use Test2::Plugin::UTF8 qw(encoding_only); + +=head1 import options + +=head2 encoding_only + +Does not import utf8 in your test and only enables the encoding mode on the output. + +=head1 NOTES + +This module currently sets output handles to have the ':utf8' output +layer. Some might prefer ':encoding(utf-8)' which is more strict about +verifying characters. There is a debate about whether or not encoding +to utf8 from perl internals can ever fail, so it may not matter. This +was also chosen because the alternative causes threads to segfault, +see L. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require.pm b/cpan/Test2-Suite/lib/Test2/Require.pm new file mode 100644 index 000000000000..dfb267ca3de7 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require.pm @@ -0,0 +1,137 @@ +package Test2::Require; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API qw/context/; +use Carp qw/croak/; + +sub skip { + my $class = shift; + croak "Class '$class' needs to implement 'skip()'"; +} + +sub import { + my $class = shift; + return if $class eq __PACKAGE__; + + my $skip = $class->skip(@_); + return unless defined $skip; + + my $ctx = context(); + $ctx->plan(0, SKIP => $skip || "No reason given."); + $ctx->release; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require - Base class and documentation for skip-unless type test +packages. + +=head1 DESCRIPTION + +Test2::Require::* packages are packages you load to ensure your test file is +skipped unless a specific requirement is met. Modules in this namespace may +subclass L if they wish, but it is not strictly necessary to do +so. + +=head1 HOW DO I WRITE A 'REQUIRE' MODULE? + +=head2 AS A SUBCLASS + + package Test2::Require::Widget; + use strict; + use warnings; + + use base 'Test2::Require'; + + sub HAVE_WIDGETS { ... }; + + sub skip { + my $class = shift; + my @import_args = @_; + + if (HAVE_WIDGETS()) { + # We have widgets, do not skip + return undef; + } + else { + # No widgets, skip the test + return "Skipped because there are no widgets" unless HAVE_WIDGETS(); + } + } + + 1; + +A subclass of L simply needs to implement a C method. +This method will receive all import arguments. This method should return undef +if the test should run, and should return a reason for skipping if the test +should be skipped. + +=head2 STAND-ALONE + +If you do not wish to subclass L then you should write an +C method: + + package Test2::Require::Widget; + use strict; + use warnings; + + use Test2::API qw/context/; + + sub HAVE_WIDGETS { ... }; + + sub import { + my $class = shift; + + # Have widgets, should run. + return if HAVE_WIDGETS(); + + # Use the context object to create the event + my $ctx = context(); + $ctx->plan(0, SKIP => "Skipped because there are no widgets"); + $ctx->release; + } + + 1; + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require/AuthorTesting.pm b/cpan/Test2-Suite/lib/Test2/Require/AuthorTesting.pm new file mode 100644 index 000000000000..d05ec6efa16e --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require/AuthorTesting.pm @@ -0,0 +1,72 @@ +package Test2::Require::AuthorTesting; +use strict; +use warnings; + +use base 'Test2::Require'; + +our $VERSION = '0.000156'; + +sub skip { + my $class = shift; + return undef if $ENV{'AUTHOR_TESTING'}; + return 'Author test, set the $AUTHOR_TESTING environment variable to run it'; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require::AuthorTesting - Only run a test when the AUTHOR_TESTING +environment variable is set. + +=head1 DESCRIPTION + +It is common practice to write tests that are only run when the AUTHOR_TESTING +environment variable is set. This module automates the (admittedly trivial) work +of creating such a test. + +=head1 SYNOPSIS + + use Test2::Require::AuthorTesting; + + ... + + done_testing; + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require/EnvVar.pm b/cpan/Test2-Suite/lib/Test2/Require/EnvVar.pm new file mode 100644 index 000000000000..0ee85b4f5ff0 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require/EnvVar.pm @@ -0,0 +1,75 @@ +package Test2::Require::EnvVar; +use strict; +use warnings; + +use Carp qw/confess/; +use base 'Test2::Require'; + +our $VERSION = '0.000156'; + +sub skip { + my $class = shift; + my ($var) = @_; + confess "no environment variable specified" unless $var; + return undef if $ENV{$var}; + return "This test only runs if the \$$var environment variable is set"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require::EnvVar - Only run a test when a specific environment variable +is set. + +=head1 DESCRIPTION + +It is common practice to write tests that are only run when an environment +variable is set. This module automates the (admittedly trivial) work of creating +such a test. + +=head1 SYNOPSIS + + use Test2::Require::EnvVar 'SOME_VAR'; + + ... + + done_testing; + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require/Fork.pm b/cpan/Test2-Suite/lib/Test2/Require/Fork.pm new file mode 100644 index 000000000000..473c29e770b2 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require/Fork.pm @@ -0,0 +1,112 @@ +package Test2::Require::Fork; +use strict; +use warnings; + +use base 'Test2::Require'; + +our $VERSION = '0.000156'; + +use Test2::Util qw/CAN_FORK/; + +sub skip { + return undef if CAN_FORK; + return "This test requires a perl capable of forking."; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require::Fork - Skip a test file unless the system supports forking + +=head1 DESCRIPTION + +It is fairly common to write tests that need to fork. Not all systems support +forking. This library does the hard work of checking if forking is supported on +the current system. If forking is not supported then this will skip all tests +and exit true. + +=head1 SYNOPSIS + + use Test2::Require::Fork; + + ... Code that forks ... + +=head1 EXPLANATION + +Checking if the current system supports forking is not simple. Here is an +example of how to do it: + + use Config; + + sub CAN_FORK { + return 1 if $Config{d_fork}; + + # Some platforms use ithreads to mimic forking + return 0 unless $^O eq 'MSWin32' || $^O eq 'NetWare'; + return 0 unless $Config{useithreads}; + return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; + + # Threads are not reliable before 5.008001 + return 0 unless $] >= 5.008001; + + # Devel::Cover currently breaks with threads + return 0 if $INC{'Devel/Cover.pm'}; + return 1; + } + +Duplicating this non-trivial code in all tests that need to fork is error-prone. It is +easy to forget bits, or get it wrong. On top of these checks, you also need to +tell the harness that no tests should run and why. + +=head1 SEE ALSO + +=over 4 + +=item L + +Similar to this module, but will skip on any perl that only has fork emulation. + +=item L + +Skip the test file if the system does not support threads. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require/Module.pm b/cpan/Test2-Suite/lib/Test2/Require/Module.pm new file mode 100644 index 000000000000..8c63d8530d92 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require/Module.pm @@ -0,0 +1,113 @@ +package Test2::Require::Module; +use strict; +use warnings; + +use base 'Test2::Require'; + +our $VERSION = '0.000156'; + +use Test2::Util qw/pkg_to_file/; + +sub skip { + my $class = shift; + my ($module, $ver) = @_; + + return "Module '$module' is not installed" + unless check_installed($module); + + return undef unless defined $ver; + + return check_version($module, $ver); +} + +sub check_installed { + my ($mod) = @_; + my $file = pkg_to_file($mod); + + return 1 if eval { require $file; 1 }; + my $error = $@; + + return 0 if $error =~ m/Can't locate \Q$file\E in \@INC/; + + # Some other error, rethrow it. + die $error; +} + +sub check_version { + my ($mod, $ver) = @_; + + return undef if eval { $mod->VERSION($ver); 1 }; + my $have = $mod->VERSION; + return "Need '$mod' version $ver, have $have."; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require::Module - Skip tests if certain packages are not installed, or +insufficient versions. + +=head1 DESCRIPTION + +Sometimes you have tests that are nice to run, but depend on tools that may not +be available. Instead of adding the tool as a dep, or making the test always +skip, it is common to make the test run conditionally. This package helps make +that possible. + +This module is modeled after L. The difference is that this +module is based on L directly, and does not go through L. +Another difference is that the packages you check for are not imported into +your namespace for you. This is intentional. + +=head1 SYNOPSIS + + # The test will be skipped unless Some::Module is installed, any version. + use Test2::Require::Module 'Some::Module'; + + # The test will be skipped unless 'Other::Module' is installed and at + # version '5.555' or greater. + use Test2::Require::Module 'Other::Module' => '5.555'; + + # We now need to use them directly, Test2::Require::Module does not import + # them for us. + use Some::Module; + use Other::Module; + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require/Perl.pm b/cpan/Test2-Suite/lib/Test2/Require/Perl.pm new file mode 100644 index 000000000000..d42394bf7a84 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require/Perl.pm @@ -0,0 +1,79 @@ +package Test2::Require::Perl; +use strict; +use warnings; + +use base 'Test2::Require'; + +our $VERSION = '0.000156'; + +use Test2::Util qw/pkg_to_file/; +use Scalar::Util qw/reftype/; + +sub skip { + my $class = shift; + my ($ver) = @_; + + return undef if eval "no warnings 'portable'; require $ver; 1"; + my $error = $@; + return $1 if $error =~ m/^(Perl \S* required)/i; + die $error; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require::Perl - Skip the test unless the necessary version of Perl is +installed. + +=head1 DESCRIPTION + +Sometimes you have tests that are nice to run, but depend on a certain version +of Perl. This package lets you run the test conditionally, depending on if the +correct version of Perl is available. + +=head1 SYNOPSIS + + # Skip the test unless perl 5.10 or greater is installed. + use Test2::Require::Perl 'v5.10'; + + # Enable 5.10 features. + use v5.10; + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require/RealFork.pm b/cpan/Test2-Suite/lib/Test2/Require/RealFork.pm new file mode 100644 index 000000000000..5cd2fdb47d59 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require/RealFork.pm @@ -0,0 +1,86 @@ +package Test2::Require::RealFork; +use strict; +use warnings; + +use base 'Test2::Require'; + +our $VERSION = '0.000156'; + +use Test2::Util qw/CAN_REALLY_FORK/; + +sub skip { + return undef if CAN_REALLY_FORK; + return "This test requires a perl capable of true forking."; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require::RealFork - Skip a test file unless the system supports true +forking + +=head1 DESCRIPTION + +It is fairly common to write tests that need to fork. Not all systems support +forking. This library does the hard work of checking if forking is supported on +the current system. If forking is not supported then this will skip all tests +and exit true. + +=head1 SYNOPSIS + + use Test2::Require::RealFork; + + ... Code that forks ... + +=head1 SEE ALSO + +=over 4 + +=item L + +Similar to this module, but will allow fork emulation. + +=item L + +Skip the test file if the system does not support threads. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Require/Threads.pm b/cpan/Test2-Suite/lib/Test2/Require/Threads.pm new file mode 100644 index 000000000000..a1e3d2a2218a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Require/Threads.pm @@ -0,0 +1,106 @@ +package Test2::Require::Threads; +use strict; +use warnings; + +use base 'Test2::Require'; + +our $VERSION = '0.000156'; + +use Test2::Util qw/CAN_THREAD/; + +sub skip { + return undef if CAN_THREAD; + return "This test requires a perl capable of threading."; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Require::Threads - Skip a test file unless the system supports threading + +=head1 DESCRIPTION + +It is fairly common to write tests that need to use threads. Not all systems +support threads. This library does the hard work of checking if threading is +supported on the current system. If threading is not supported then this will +skip all tests and exit true. + +=head1 SYNOPSIS + + use Test2::Require::Threads; + + ... Code that uses threads ... + +=head1 EXPLANATION + +Checking if the current system supports threading is not simple, here is an +example of how to do it: + + use Config; + + sub CAN_THREAD { + # Threads are not reliable before 5.008001 + return 0 unless $] >= 5.008001; + return 0 unless $Config{'useithreads'}; + + # Devel::Cover currently breaks with threads + return 0 if $INC{'Devel/Cover.pm'}; + return 1; + } + +Duplicating this non-trivial code in all tests that need to use threads is +error-prone. It is easy to forget bits, or get it wrong. On top of these checks you +also need to tell the harness that no tests should run and why. + +=head1 SEE ALSO + +=over 4 + +=item L + +Skip the test file if the system does not support forking. + +=item L + +Test2::Require::Threads uses L under the hood. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Suite.pm b/cpan/Test2-Suite/lib/Test2/Suite.pm new file mode 100644 index 000000000000..e0653ea0b899 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Suite.pm @@ -0,0 +1,382 @@ +package Test2::Suite; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Suite - Distribution with a rich set of tools built upon the Test2 +framework. + +=head1 DESCRIPTION + +Rich set of tools, plugins, bundles, etc built upon the L testing +library. If you are interested in writing tests, this is the distribution for +you. + +=head2 WHAT ARE TOOLS, PLUGINS, AND BUNDLES? + +=over 4 + +=item TOOLS + +Tools are packages that export functions for use in test files. These functions +typically generate events. Tools B alter behavior of other tools, +or the system in general. + +=item PLUGINS + +Plugins are packages that produce effects, or alter behavior of tools. An +example would be a plugin that causes the test to bail out after the first +failure. Plugins B export anything. + +=item BUNDLES + +Bundles are collections of tools and plugins. A bundle should load and +re-export functions from Tool packages. A bundle may also load and configure +any number of plugins. + +=back + +If you want to write something that both exports new functions, and effects +behavior, you should write both a Tools distribution, and a Plugin distribution, +then a Bundle that loads them both. This is important as it helps avoid the +problem where a package exports much-desired tools, but +also produces undesirable side effects. + +=head1 INCLUDED BUNDLES + +=over 4 + +=item Test2::V# + +These do not live in the bundle namespace as they are the primary ways to use +Test2::Suite. + +The current latest is L. + + use Test2::V0; + # strict and warnings are on for you now. + + ok(...); + + # Note: is does deep checking, unlike the 'is' from Test::More. + is(...); + + ... + + done_testing; + +This bundle includes every tool listed in the L section below, +except for L. This bundle provides most of what +anyone writing tests could need. This is also the preferred bundle/toolset of +the L author. + +See L for complete documentation. + +=item Extended + +B<** Deprecated **> See L + + use Test2::Bundle::Extended; + # strict and warnings are on for you now. + + ok(...); + + # Note: is does deep checking, unlike the 'is' from Test::More. + is(...); + + ... + + done_testing; + +This bundle includes every tool listed in the L section below, +except for L. This bundle provides most of what +anyone writing tests could need. This is also the preferred bundle/toolset of +the L author. + +See L for complete documentation. + +=item More + + use Test2::Bundle::More; + use strict; + use warnings; + + plan 3; # Or you can use done_testing at the end + + ok(...); + + is(...); # Note: String compare + + is_deeply(...); + + ... + + done_testing; # Use instead of plan + +This bundle is meant to be a I drop-in replacement for L. +There are some notable differences to be aware of however. Some exports are +missing: C, C, C, C<$TODO>, C, C, +C. As well it is no longer possible to set the plan at import: +C<< use .. tests => 5 >>. C<$TODO> has been replaced by the C +function. Planning is done using C, C, or C. + +See L for complete documentation. + +=item Simple + + use Test2::Bundle::Simple; + use strict; + use warnings; + + plan 1; + + ok(...); + +This bundle is meant to be a I drop-in replacement for L. +See L for complete documentation. + +=back + +=head1 INCLUDED TOOLS + +=over 4 + +=item Basic + +Basic provides most of the essential tools previously found in L. +However it does not export any tools used for comparison. The basic C, +C, C functions are present, as are functions for planning. + +See L for complete documentation. + +=item Compare + +This provides C, C, C, C, and several additional +helpers. B These are all I comparison tools and work like a +combination of L's C and C. + +See L for complete documentation. + +=item ClassicCompare + +This provides L flavored C, C, C, C, and +C. It also provides C. + +See L for complete documentation. + +=item Class + +This provides functions for testing objects and classes, things like C. + +See L for complete documentation. + +=item Defer + +This provides functions for writing test functions in one place, but running +them later. This is useful for testing things that run in an altered state. + +See L for complete documentation. + +=item Encoding + +This exports a single function that can be used to change the encoding of all +your test output. + +See L for complete documentation. + +=item Exports + +This provides tools for verifying exports. You can verify that functions have +been imported, or that they have not been imported. + +See L for complete documentation. + +=item Mock + +This provides tools for mocking objects and classes. This is based largely on +L, but several interface improvements have been added that cannot +be added to Mock::Quick itself without breaking backwards compatibility. + +See L for complete documentation. + +=item Ref + +This exports tools for validating and comparing references. + +See L for complete documentation. + +=item Spec + +This is an RSPEC implementation with concurrency support. + +See L for more details. + +=item Subtest + +This exports tools for running subtests. + +See L for complete documentation. + +=item Target + +This lets you load the package(s) you intend to test, and alias them into +constants/package variables. + +See L for complete documentation. + +=back + +=head1 INCLUDED PLUGINS + +=over 4 + +=item BailOnFail + +The much requested "bail-out on first failure" plugin. When this plugin is +loaded, any failure will cause the test to bail out immediately. + +See L for complete documentation. + +=item DieOnFail + +The much requested "die on first failure" plugin. When this plugin is +loaded, any failure will cause the test to die immediately. + +See L for complete documentation. + +=item ExitSummary + +This plugin gives you statistics and diagnostics at the end of your test in the +event of a failure. + +See L for complete documentation. + +=item SRand + +Use this to set the random seed to a specific seed, or to the current date. + +See L for complete documentation. + +=item UTF8 + +Turn on utf8 for your testing. This sets the current file to be utf8, it also +sets STDERR, STDOUT, and your formatter to all output utf8. + +See L for complete documentation. + +=back + +=head1 INCLUDED REQUIREMENT CHECKERS + +=over 4 + +=item AuthorTesting + +Using this package will cause the test file to be skipped unless the +AUTHOR_TESTING environment variable is set. + +See L for complete documentation. + +=item EnvVar + +Using this package will cause the test file to be skipped unless a custom +environment variable is set. + +See L for complete documentation. + +=item Fork + +Using this package will cause the test file to be skipped unless the system is +capable of forking (including emulated forking). + +See L for complete documentation. + +=item RealFork + +Using this package will cause the test file to be skipped unless the system is +capable of true forking. + +See L for complete documentation. + +=item Module + +Using this package will cause the test file to be skipped unless the specified +module is installed (and optionally at a minimum version). + +See L for complete documentation. + +=item Perl + +Using this package will cause the test file to be skipped unless the specified +minimum perl version is met. + +See L for complete documentation. + +=item Threads + +Using this package will cause the test file to be skipped unless the system has +threading enabled. + +B This will not turn threading on for you. + +See L for complete documentation. + +=back + +=head1 SEE ALSO + +See the L documentation for a namespace map. Everything in this +distribution uses L. + +L is the Test2 Manual. + +=head1 CONTACTING US + +Many Test2 developers and users lurk on 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-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Todo.pm b/cpan/Test2-Suite/lib/Test2/Todo.pm new file mode 100644 index 000000000000..6f2803d0b490 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Todo.pm @@ -0,0 +1,184 @@ +package Test2::Todo; +use strict; +use warnings; + +use Carp qw/croak/; +use Test2::Util::HashBase qw/hub _filter reason/; + +use Test2::API qw/test2_stack/; + +use overload '""' => \&reason, fallback => 1; + +our $VERSION = '0.000156'; + +sub init { + my $self = shift; + + my $reason = $self->{+REASON}; + croak "The 'reason' attribute is required" unless defined $reason; + + my $hub = $self->{+HUB} ||= test2_stack->top; + + $self->{+_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'; + + if ($active_hub == $hub) { + $event->set_todo($reason) if $event->can('set_todo'); + $event->add_amnesty({tag => 'TODO', details => $reason}); + $event->set_effective_pass(1) if $event->isa('Test2::Event::Ok'); + } + else { + $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1}); + } + + return $event; + }, + inherit => 1, + todo => $reason, + ); +} + +sub end { + my $self = shift; + my $hub = $self->{+HUB} or return; + + $hub->pre_unfilter($self->{+_FILTER}); + delete $self->{+HUB}; + delete $self->{+_FILTER}; +} + +sub DESTROY { + my $self = shift; + $self->end; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Todo - TODO extension for Test2. + +=head1 DESCRIPTION + +This is an object that lets you create and manage TODO states for tests. This +is an extension, not a plugin or a tool. This library can be used by plugins +and tools to manage todo states. + +If you simply want to write a todo test then you should look at the C +function provided by L. + +=head1 SYNOPSIS + + use Test2::Todo; + + # Start the todo + my $todo = Test2::Todo->new(reason => 'Fix later'); + + # Will be considered todo, so suite still passes + ok(0, "oops"); + + # End the todo + $todo->end; + + # TODO has ended, this test will actually fail. + ok(0, "oops"); + +=head1 CONSTRUCTION OPTIONS + +=over 4 + +=item reason (required) + +The reason for the todo, this can be any defined value. + +=item hub (optional) + +The hub to which the TODO state should be applied. If none is provided then the +current global hub is used. + +=back + +=head1 INSTANCE METHODS + +=over 4 + +=item $todo->end + +End the todo state. + +=back + +=head1 CLASS METHODS + +=over 4 + +=item $count = Test2::Todo->hub_in_todo($hub) + +If the hub has any todo objects this will return the total number of them. If +the hub has no todo objects it will return 0. + +=back + +=head1 OTHER NOTES + +=head2 How it works + +When an instance is created a filter sub is added to the L. This +filter will set the C and C attributes on all events as they +come in. When the instance is destroyed, or C is called, the filter is +removed. + +When a new hub is pushed (such as when a subtest is started) the new hub will +inherit the filter, but it will only set C, it will not set C +on events in child hubs. + +=head2 $todo->end is called at destruction + +If your C<$todo> object falls out of scope and gets garbage collected, the todo +will end. + +=head2 Can I use multiple instances? + +Yes. The most recently created one that is still active will win. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools.pm b/cpan/Test2-Suite/lib/Test2/Tools.pm new file mode 100644 index 000000000000..b17aef052f47 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools.pm @@ -0,0 +1,117 @@ +package Test2::Tools; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools - Documentation for Tools. + +=head1 DESCRIPTION + +Tools are packages that export test functions, typically all related to a +specific aspect of testing. If you have a couple different categories of +exports then you may want to break them into separate modules. + +Tools should export testing functions. Loading tools B have side +effects, or alter the behavior of other tools. If you want to alter behaviors +or create side effects then you probably want to write a L. + +=head1 FAQ + +=over 4 + +=item Why is it called Test2::Tools, and not Test2::Tool? + +This question arises since Tools is the only namespace in the plural. This is +because each Plugin should be a distinct unit of functionality, but a Tools +dist can (and usually should) export several tools. A bundle is also typically +described as a single unit. Nobody would like Test2::Bundles::Foo. + +=item Should my tools subclass Test2::Tools? + +No. Currently this class is empty. Eventually we may want to add behavior, in +which case we do not want anyone to already be subclassing it. + +=back + +=head1 HOW DO I WRITE A 'TOOLS' MODULE? + +It is very easy to write tools: + + package Test2::Tools::Mine + use strict; + use warnings; + + # All tools should use the context() function. + use Test2::API qw/context/; + + our @EXPORTS = qw/ok plan/; + use base 'Exporter'; + + sub ok($;$) { + my ($bool, $name) = @_; + + # All tool functions should start by grabbing a context + my $ctx = context(); + + # The context is the primary interface for generating events + $ctx->ok($bool, $name); + + # When you are done you release the context + $ctx->release; + + return $bool ? 1 : 0; + } + + sub plan { + my ($max) = @_; + my $ctx = context(); + $ctx->plan($max); + $ctx->release; + } + + 1; + +See L for documentation on what the C<$ctx> object can do. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/AsyncSubtest.pm b/cpan/Test2-Suite/lib/Test2/Tools/AsyncSubtest.pm new file mode 100644 index 000000000000..8beaa68b9dcc --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/AsyncSubtest.pm @@ -0,0 +1,176 @@ +package Test2::Tools::AsyncSubtest; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::IPC; +use Test2::AsyncSubtest; +use Test2::API qw/context/; +use Carp qw/croak/; + +our @EXPORT = qw/async_subtest fork_subtest thread_subtest/; +use base 'Exporter'; + +sub async_subtest { + my $name = shift; + my ($params, $code); + $params = shift(@_) if @_ && ref($_[0]) eq 'HASH'; + $code = shift(@_) if @_ && ref($_[0]) eq 'CODE'; + + my $ctx = context(); + + my $subtest = Test2::AsyncSubtest->new(name => $name, context => 1, hub_init_args => $params); + + $subtest->run($code, $subtest) if $code; + + $ctx->release; + return $subtest; +} + +sub fork_subtest { + my $name = shift; + my ($params, $code); + $params = shift(@_) if @_ && ref($_[0]) eq 'HASH'; + $code = shift(@_) if @_ && ref($_[0]) eq 'CODE'; + + my $ctx = context(); + + croak "fork_subtest requires a CODE reference as the second argument" + unless ref($code) eq 'CODE'; + + my $subtest = Test2::AsyncSubtest->new(name => $name, context => 1, hub_init_args => $params); + + $subtest->run_fork($code, $subtest); + + $ctx->release; + return $subtest; +} + +sub thread_subtest { + my $name = shift; + my ($params, $code); + $params = shift(@_) if @_ && ref($_[0]) eq 'HASH'; + $code = shift(@_) if @_ && ref($_[0]) eq 'CODE'; + + my $ctx = context(); + + croak "thread_subtest requires a CODE reference as the second argument" + unless ref($code) eq 'CODE'; + + my $subtest = Test2::AsyncSubtest->new(name => $name, context => 1, hub_init_args => $params); + + $subtest->run_thread($code, $subtest); + + $ctx->release; + return $subtest; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::AsyncSubtest - Tools for writing async subtests. + +=head1 DESCRIPTION + +These are tools for writing async subtests. Async subtests are subtests which +can be started and stashed so that they can continue to receive events while +other events are also being generated. + +=head1 SYNOPSIS + + use Test2::Bundle::Extended; + use Test2::Tools::AsyncSubtest; + + my $ast1 = async_subtest local => sub { + ok(1, "Inside subtest"); + }; + + my $ast2 = fork_subtest child => sub { + ok(1, "Inside subtest in another process"); + }; + + # You must call finish on the subtests you create. Finish will wait/join on + # any child processes and threads. + $ast1->finish; + $ast2->finish; + + done_testing; + +=head1 EXPORTS + +Everything is exported by default. + +=over 4 + +=item $ast = async_subtest $name + +=item $ast = async_subtest $name => sub { ... } + +=item $ast = async_subtest $name => \%hub_params, sub { ... } + +Create an async subtest. Run the codeblock if it is provided. + +=item $ast = fork_subtest $name => sub { ... } + +=item $ast = fork_subtest $name => \%hub_params, sub { ... } + +Create an async subtest. Run the codeblock in a forked process. + +=item $ast = thread_subtest $name => sub { ... } + +=item $ast = thread_subtest $name => \%hub_params, sub { ... } + +B<** DISCOURAGED **> Threads are fragile. Thread tests are not even run unless +the AUTHOR_TESTING or T2_DO_THREAD_TESTS env vars are enabled. + +Create an async subtest. Run the codeblock in a thread. + +=back + +=head1 NOTES + +=over 4 + +=item Async Subtests are always buffered. + +=back + +=head1 SOURCE + +The source code repository for Test2-AsyncSubtest 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/Tools/Basic.pm b/cpan/Test2-Suite/lib/Test2/Tools/Basic.pm new file mode 100644 index 000000000000..4bb88a4065b7 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Basic.pm @@ -0,0 +1,355 @@ +package Test2::Tools::Basic; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; +use Test2::API qw/context/; + +our @EXPORT = qw{ + ok pass fail diag note todo skip + plan skip_all done_testing bail_out +}; +use base 'Exporter'; + +sub ok($;$@) { + my ($bool, $name, @diag) = @_; + my $ctx = context(); + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool ? 1 : 0; +} + +sub pass { + my ($name) = @_; + my $ctx = context(); + $ctx->ok(1, $name); + $ctx->release; + return 1; +} + +sub fail { + my ($name, @diag) = @_; + my $ctx = context(); + $ctx->ok(0, $name, \@diag); + $ctx->release; + return 0; +} + +sub diag { + my $ctx = context(); + $ctx->diag( join '', grep { defined $_ } @_ ); + $ctx->release; +} + +sub note { + my $ctx = context(); + $ctx->note( join '', grep { defined $_ } @_ ); + $ctx->release; +} + +sub todo { + my $reason = shift; + my $code = shift; + + require Test2::Todo unless $INC{'Test2/Todo.pm'}; + my $todo = Test2::Todo->new(reason => $reason); + + return $code->() if $code; + + croak "Cannot use todo() in a void context without a codeblock" + unless defined wantarray; + + return $todo; +} + +sub skip { + my ($why, $num) = @_; + $num ||= 1; + my $ctx = context(); + $ctx->skip("skipped test", $why) for 1 .. $num; + $ctx->release; + no warnings 'exiting'; + last SKIP; +} + +sub plan { + my $plan = shift; + my $ctx = context(); + + if ($plan && $plan =~ m/[^0-9]/) { + if ($plan eq 'tests') { + $plan = shift; + } + elsif ($plan eq 'skip_all') { + skip_all(@_); + $ctx->release; + return; + } + } + + $ctx->plan($plan); + $ctx->release; +} + +sub skip_all { + my ($reason) = @_; + my $ctx = context(); + $ctx->plan(0, SKIP => $reason); + $ctx->release if $ctx; +} + +sub done_testing { + my $ctx = context(); + $ctx->hub->finalize($ctx->trace, 1); + $ctx->release; +} + +sub bail_out { + my ($reason) = @_; + my $ctx = context(); + $ctx->bail($reason); + $ctx->release if $ctx; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Basic - Test2 implementation of the basic testing tools. + +=head1 DESCRIPTION + +This is a L based implementation of the more basic tools originally +provided by L. Not all L tools are provided by this +package, only the basic/simple ones. Some tools have been modified for better +diagnostics capabilities. + +=head1 SYNOPSIS + + use Test2::Tools::Basic; + + ok($x, "simple test"); + + if ($passing) { + pass('a passing test'); + } + else { + fail('a failing test'); + } + + diag "This is a diagnostics message on STDERR"; + note "This is a diagnostics message on STDOUT"; + + { + my $todo = todo "Reason for todo"; + ok(0, "this test is todo"); + } + + ok(1, "this test is not todo"); + + todo "reason" => sub { + ok(0, "this test is todo"); + }; + + ok(1, "this test is not todo"); + + SKIP: { + skip "This will wipe your drive"; + + # This never gets run: + ok(!system('sudo rm -rf /'), "Wipe drive"); + } + + done_testing; + +=head1 EXPORTS + +All subs are exported by default. + +=head2 PLANNING + +=over 4 + +=item plan($num) + +=item plan('tests' => $num) + +=item plan('skip_all' => $reason) + +Set the number of tests that are expected. This must be done first or last, +never in the middle of testing. + +For legacy compatibility you can specify 'tests' as the first argument before +the number. You can also use this to skip all with the 'skip_all' prefix, +followed by a reason for skipping. + +=item skip_all($reason) + +Set the plan to 0 with a reason, then exit true. This should be used before any +tests are run. + +=item done_testing + +Used to mark the end of testing. This is a safe way to have a dynamic or +unknown number of tests. + +=item bail_out($reason) + +Invoked when something has gone horribly wrong: stop everything, kill all threads and +processes, end the process with a false exit status. + +=back + +=head2 ASSERTIONS + +=over 4 + +=item ok($bool) + +=item ok($bool, $name) + +=item ok($bool, $name, @diag) + +Simple assertion. If C<$bool> is true the test passes, and if it is false the test +fails. The test name is optional, and all arguments after the name are added as +diagnostics message if and only if the test fails. If the test passes all the +diagnostics arguments will be ignored. + +=item pass() + +=item pass($name) + +Fire off a passing test (a single Ok event). The name is optional + +=item fail() + +=item fail($name) + +=item fail($name, @diag) + +Fire off a failing test (a single Ok event). The name and diagnostics are optional. + +=back + +=head2 DIAGNOSTICS + +=over 4 + +=item diag(@messages) + +Write diagnostics messages. All items in C<@messages> will be joined into a +single string with no separator. When using TAP, diagnostics are sent to STDERR. + +=item note(@messages) + +Write note-diagnostics messages. All items in C<@messages> will be joined into +a single string with no separator. When using TAP, notes are sent to STDOUT. + +=back + +=head2 META + +=over 4 + +=item $todo = todo($reason) + +=item todo $reason => sub { ... } + +This is used to mark some results as TODO. TODO means that the test may fail, +but will not cause the overall test suite to fail. + +There are two ways to use this. The first is to use a codeblock, and the TODO will +only apply to the codeblock. + + ok(1, "before"); # Not TODO + + todo 'this will fail' => sub { + # This is TODO, as is any other test in this block. + ok(0, "blah"); + }; + + ok(1, "after"); # Not TODO + +The other way is to use a scoped variable. TODO will end when the variable is +destroyed or set to undef. + + ok(1, "before"); # Not TODO + + { + my $todo = todo 'this will fail'; + + # This is TODO, as is any other test in this block. + ok(0, "blah"); + }; + + ok(1, "after"); # Not TODO + +This is the same thing, but without the C<{...}> scope. + + ok(1, "before"); # Not TODO + + my $todo = todo 'this will fail'; + + ok(0, "blah"); # TODO + + $todo = undef; + + ok(1, "after"); # Not TODO + +=item skip($why) + +=item skip($why, $count) + +This is used to skip some tests. This requires you to wrap your tests in a +block labeled C. This is somewhat magical. If no C<$count> is specified +then it will issue a single result. If you specify C<$count> it will issue that +many results. + + SKIP: { + skip "This will wipe your drive"; + + # This never gets run: + ok(!system('sudo rm -rf /'), "Wipe drive"); + } + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Class.pm b/cpan/Test2-Suite/lib/Test2/Tools/Class.pm new file mode 100644 index 000000000000..859377ad7e12 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Class.pm @@ -0,0 +1,193 @@ +package Test2::Tools::Class; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API qw/context/; +use Test2::Util::Ref qw/render_ref/; + +use Scalar::Util qw/blessed/; + +our @EXPORT = qw/can_ok isa_ok DOES_ok/; +use base 'Exporter'; + +# For easier grepping +# sub isa_ok is defined here +# sub can_ok is defined here +# sub DOES_ok is defined here +BEGIN { + for my $op (qw/isa can DOES/) { + my $sub = sub($;@) { + my ($thing, @args) = @_; + my $ctx = context(); + + my (@items, $name); + if (ref($args[0]) eq 'ARRAY') { + $name = $args[1]; + @items = @{$args[0]}; + } + else { + @items = @args; + } + + my $thing_name = ref($thing) ? render_ref($thing) : defined($thing) ? "$thing" : ""; + $thing_name =~ s/\n/\\n/g; + $thing_name =~ s/#//g; + $thing_name =~ s/\(0x[a-f0-9]+\)//gi; + + $name ||= @items == 1 ? "$thing_name\->$op('$items[0]')" : "$thing_name\->$op(...)"; + + unless (defined($thing) && (blessed($thing) || !ref($thing) && length($thing))) { + my $thing = defined($thing) + ? ref($thing) || "'$thing'" + : ''; + + $ctx->ok(0, $name, ["$thing is neither a blessed reference or a package name."]); + + $ctx->release; + return 0; + } + + unless(UNIVERSAL->can($op) || $thing->can($op)) { + $ctx->skip($name, "'$op' is not supported on this platform"); + $ctx->release; + return 1; + } + + my $file = $ctx->trace->file; + my $line = $ctx->trace->line; + + my @bad; + for my $item (@items) { + my ($bool, $ok, $err); + + { + local ($@, $!); + $ok = eval qq/#line $line "$file"\n\$bool = \$thing->$op(\$item); 1/; + $err = $@; + } + + die $err unless $ok; + next if $bool; + + push @bad => $item; + } + + $ctx->ok( !@bad, $name, [map { "Failed: $thing_name\->$op('$_')" } @bad]); + + $ctx->release; + + return !@bad; + }; + + no strict 'refs'; + *{$op . "_ok"} = $sub; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Class - Test2 implementation of the tools for testing classes. + +=head1 DESCRIPTION + +L based tools for validating classes and objects. These are similar to +some tools from L, but they have a more consistent interface. + +=head1 SYNOPSIS + + use Test2::Tools::Class; + + isa_ok($CLASS_OR_INSTANCE, $PARENT_CLASS1, $PARENT_CLASS2, ...); + isa_ok($CLASS_OR_INSTANCE, [$PARENT_CLASS1, $PARENT_CLASS2, ...], "Test Name"); + + can_ok($CLASS_OR_INSTANCE, $METHOD1, $METHOD2, ...); + can_ok($CLASS_OR_INSTANCE, [$METHOD1, $METHOD2, ...], "Test Name"); + + DOES_ok($CLASS_OR_INSTANCE, $ROLE1, $ROLE2, ...); + DOES_ok($CLASS_OR_INSTANCE, [$ROLE1, $ROLE2, ...], "Test Name"); + +=head1 EXPORTS + +All subs are exported by default. + +=over 4 + +=item can_ok($thing, @methods) + +=item can_ok($thing, \@methods, $test_name) + +This checks that C<$thing> (either a class name, or a blessed instance) has the +specified methods. + +If the second argument is an arrayref then it will be used as the list of +methods leaving the third argument to be the test name. + +=item isa_ok($thing, @classes) + +=item isa_ok($thing, \@classes, $test_name) + +This checks that C<$thing> (either a class name, or a blessed instance) is or +subclasses the specified classes. + +If the second argument is an arrayref then it will be used as the list of +classes leaving the third argument to be the test name. + +=item DOES_ok($thing, @roles) + +=item DOES_ok($thing, \@roles, $test_name) + +This checks that C<$thing> (either a class name, or a blessed instance) does +the specified roles. + +If the second argument is an arrayref then it will be used as the list of +roles leaving the third argument to be the test name. + +B This uses the C<< $class->DOES(...) >> method, not the C +method Moose provides. + +B Not all perls have the C method, if you use this on those +perls the test will be skipped. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/ClassicCompare.pm b/cpan/Test2-Suite/lib/Test2/Tools/ClassicCompare.pm new file mode 100644 index 000000000000..1acdfa325590 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/ClassicCompare.pm @@ -0,0 +1,514 @@ +package Test2::Tools::ClassicCompare; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +our @EXPORT = qw/is is_deeply isnt like unlike cmp_ok/; +use base 'Exporter'; + +use Carp qw/carp/; +use Scalar::Util qw/reftype/; + +use Test2::API qw/context/; +use Test2::Compare qw/compare strict_convert/; +use Test2::Util::Ref qw/rtype render_ref/; +use Test2::Util::Table qw/table/; + +use Test2::Compare::Array(); +use Test2::Compare::Bag(); +use Test2::Compare::Custom(); +use Test2::Compare::Event(); +use Test2::Compare::Hash(); +use Test2::Compare::Meta(); +use Test2::Compare::Number(); +use Test2::Compare::Object(); +use Test2::Compare::OrderedSubset(); +use Test2::Compare::Pattern(); +use Test2::Compare::Ref(); +use Test2::Compare::Regex(); +use Test2::Compare::Scalar(); +use Test2::Compare::Set(); +use Test2::Compare::String(); +use Test2::Compare::Undef(); +use Test2::Compare::Wildcard(); + +sub is($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my @caller = caller; + + my $delta = compare($got, $exp, \&is_convert); + + if ($delta) { + $ctx->fail($name, $delta->diag, @diag); + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; +} + +sub isnt($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my @caller = caller; + + my $delta = compare($got, $exp, \&isnt_convert); + + if ($delta) { + $ctx->fail($name, $delta->diag, @diag); + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; +} + +sub is_convert { + my ($thing) = @_; + return Test2::Compare::Undef->new() + unless defined $thing; + return Test2::Compare::String->new(input => $thing); +} + +sub isnt_convert { + my ($thing) = @_; + return Test2::Compare::Undef->new() + unless defined $thing; + my $str = Test2::Compare::String->new(input => $thing, negate => 1); +} + +sub like($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my $delta = compare($got, $exp, \&like_convert); + + if ($delta) { + $ctx->fail($name, $delta->diag, @diag); + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; +} + +sub unlike($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my $delta = compare($got, $exp, \&unlike_convert); + + if ($delta) { + $ctx->fail($name, $delta->diag, @diag); + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; +} + +sub like_convert { + my ($thing) = @_; + return Test2::Compare::Pattern->new( + pattern => $thing, + stringify_got => 1, + ); +} + +sub unlike_convert { + my ($thing) = @_; + return Test2::Compare::Pattern->new( + negate => 1, + stringify_got => 1, + pattern => $thing, + ); +} + +sub is_deeply($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my @caller = caller; + + my $delta = compare($got, $exp, \&strict_convert); + + if ($delta) { + # Temporary thing. + my $count = 0; + my $implicit = 0; + my @deltas = ($delta); + while (my $d = shift @deltas) { + my $add = $d->children; + push @deltas => @$add if $add && @$add; + next if $d->verified; + $count++; + $implicit++ if $d->note && $d->note eq 'implicit end'; + } + + if ($implicit == $count) { + $ctx->ok(1, $name); + my $meth = $ENV{AUTHOR_TESTING} ? 'throw' : 'alert'; + my $type = $delta->render_check; + $ctx->$meth( + join "\n", + "!!! NOTICE OF BEHAVIOR CHANGE !!!", + "This test uses at least 1 $type check without using end() or etc().", + "The exising behavior is to default to etc() when inside is_deeply().", + "The new behavior is to default to end().", + "This test will soon start to fail with the following diagnostics:", + $delta->diag->as_string, + "", + ); + } + else { + $ctx->fail($name, $delta->diag, @diag); + } + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; +} + +our %OPS = ( + '==' => 'num', + '!=' => 'num', + '>=' => 'num', + '<=' => 'num', + '>' => 'num', + '<' => 'num', + '<=>' => 'num', + + 'eq' => 'str', + 'ne' => 'str', + 'gt' => 'str', + 'lt' => 'str', + 'ge' => 'str', + 'le' => 'str', + 'cmp' => 'str', + '!~' => 'str', + '=~' => 'str', + + '&&' => 'logic', + '||' => 'logic', + 'xor' => 'logic', + 'or' => 'logic', + 'and' => 'logic', + '//' => 'logic', + + '&' => 'bitwise', + '|' => 'bitwise', + + '~~' => 'match', +); +sub cmp_ok($$$;$@) { + my ($got, $op, $exp, $name, @diag) = @_; + + my $ctx = context(); + + # Warnings and syntax errors should report to the cmp_ok call, not the test + # context. They may not be the same. + my ($pkg, $file, $line) = caller; + + my $type = $OPS{$op}; + if (!$type) { + carp "operator '$op' is not supported (you can add it to %Test2::Tools::ClassicCompare::OPS)"; + $type = 'unsupported'; + } + + local ($@, $!, $SIG{__DIE__}); + + my $test; + my $lived = eval <<" EOT"; +#line $line "(eval in cmp_ok) $file" +\$test = (\$got $op \$exp); +1; + EOT + my $error = $@; + $ctx->send_event('Exception', error => $error) unless $lived; + + if ($test && $lived) { + $ctx->ok(1, $name); + $ctx->release; + return 1; + } + + # Ugh, it failed. Do roughly the same thing Test::More did to try and show + # diagnostics, but make it better by showing both the overloaded and + # unoverloaded form if overloading is in play. Also unoverload numbers, + # Test::More only unoverloaded strings. + + my ($display_got, $display_exp); + if($type eq 'str') { + $display_got = defined($got) ? "$got" : undef; + $display_exp = defined($exp) ? "$exp" : undef; + } + elsif($type eq 'num') { + $display_got = defined($got) ? $got + 0 : undef; + $display_exp = defined($exp) ? $exp + 0 : undef; + } + else { # Well, we did what we could. + $display_got = $got; + $display_exp = $exp; + } + + my $got_ref = ref($got) ? render_ref($got) : $got; + my $exp_ref = ref($exp) ? render_ref($exp) : $exp; + + my @table; + my $show_both = ( + (defined($got) && $got_ref ne "$display_got") + || + (defined($exp) && $exp_ref ne "$display_exp") + ); + + if ($show_both) { + @table = table( + header => ['TYPE', 'GOT', 'OP', 'CHECK'], + rows => [ + [$type, $display_got, $op, $lived ? $display_exp : ''], + ['orig', $got_ref, '', $exp_ref], + ], + ); + } + else { + @table = table( + header => ['GOT', 'OP', 'CHECK'], + rows => [[$display_got, $op, $lived ? $display_exp : '']], + ); + } + + $ctx->ok(0, $name, [join("\n", @table), @diag]); + $ctx->release; + return 0; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::ClassicCompare - Classic (Test::More style) comparison tools. + +=head1 DESCRIPTION + +This provides comparison functions that behave like they did in L, +unlike the L plugin which has modified them. + +=head1 SYNOPSIS + + use Test2::Tools::ClassicCompare qw/is is_deeply isnt like unlike cmp_ok/; + + is($got, $expect, "These are the same when stringified"); + isnt($got, $unexpect, "These are not the same when stringified"); + + like($got, qr/.../, "'got' matches the pattern"); + unlike($got, qr/.../, "'got' does not match the pattern"); + + is_deeply($got, $expect, "These structures are same when checked deeply"); + + cmp_ok($GOT, $OP, $WANT, 'Compare these items using the specified operatr'); + +=head1 EXPORTS + +=over 4 + +=item $bool = is($got, $expect) + +=item $bool = is($got, $expect, $name) + +=item $bool = is($got, $expect, $name, @diag) + +This does a string comparison of the two arguments. If the two arguments are the +same after stringification the test passes. The test will also pass if both +arguments are undef. + +The test C<$name> is optional. + +The test C<@diag> is optional, it is extra diagnostics messages that will be +displayed if the test fails. The diagnostics are ignored if the test passes. + +It is important to note that this tool considers C<"1"> and C<"1.0"> to not be +equal as it uses a string comparison. + +See L if you want an C function that tries +to be smarter for you. + +=item $bool = isnt($got, $dont_expect) + +=item $bool = isnt($got, $dont_expect, $name) + +=item $bool = isnt($got, $dont_expect, $name, @diag) + +This is the inverse of C, it passes when the strings are not the same. + +=item $bool = like($got, $pattern) + +=item $bool = like($got, $pattern, $name) + +=item $bool = like($got, $pattern, $name, @diag) + +Check if C<$got> matches the specified pattern. Will fail if it does not match. + +The test C<$name> is optional. + +The test C<@diag> is optional. It contains extra diagnostics messages that will +be displayed if the test fails. The diagnostics are ignored if the test passes. + +=item $bool = unlike($got, $pattern) + +=item $bool = unlike($got, $pattern, $name) + +=item $bool = unlike($got, $pattern, $name, @diag) + +This is the inverse of C. This will fail if C<$got> matches +C<$pattern>. + +=item $bool = is_deeply($got, $expect) + +=item $bool = is_deeply($got, $expect, $name) + +=item $bool = is_deeply($got, $expect, $name, @diag) + +This does a deep check, comparing the structures in C<$got> with those in +C<$expect>. It will recurse into hashrefs, arrayrefs, and scalar refs. All +other values will be stringified and compared as strings. It is important to +note that this tool considers C<"1"> and C<"1.0"> to not be equal as it uses a +string comparison. + +This is the same as C. + +=item cmp_ok($got, $op, $expect) + +=item cmp_ok($got, $op, $expect, $name) + +=item cmp_ok($got, $op, $expect, $name, @diag) + +Compare C<$got> to C<$expect> using the operator specified in C<$op>. This is +effectively an C with some other stuff to make it +more sane. This is useful for comparing numbers, overloaded objects, etc. + +B Your input is passed as-is to the comparison. +If the comparison fails between two overloaded objects, the diagnostics will +try to show you the overload form that was used in comparisons. It is possible +that the diagnostics will be wrong, though attempts have been made to improve +them since L. + +B If the comparison results in an exception then the test will +fail and the exception will be shown. + +C has an internal list of operators it supports. If you provide an +unsupported operator it will issue a warning. You can add operators to the +C<%Test2::Tools::ClassicCompare::OPS> hash, the key should be the operator, and +the value should either be 'str' for string comparison operators, 'num' for +numeric operators, or any other true value for other operators. + +Supported operators: + +=over 4 + +=item == (num) + +=item != (num) + +=item >= (num) + +=item <= (num) + +=item > (num) + +=item < (num) + +=item <=> (num) + +=item eq (str) + +=item ne (str) + +=item gt (str) + +=item lt (str) + +=item ge (str) + +=item le (str) + +=item cmp (str) + +=item !~ (str) + +=item =~ (str) + +=item && + +=item || + +=item xor + +=item or + +=item and + +=item // + +=item & + +=item | + +=item ~~ + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Compare.pm b/cpan/Test2-Suite/lib/Test2/Tools/Compare.pm new file mode 100644 index 000000000000..668463b0e728 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Compare.pm @@ -0,0 +1,1921 @@ +package Test2::Tools::Compare; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +use Test2::API qw/context/; +use Test2::Util::Ref qw/rtype/; +use Test2::Util qw/pkg_to_file/; + +use Test2::Compare qw{ + compare + get_build push_build pop_build build + strict_convert relaxed_convert +}; + +use Test2::Compare::Array(); +use Test2::Compare::Bag(); +use Test2::Compare::Bool(); +use Test2::Compare::Custom(); +use Test2::Compare::Event(); +use Test2::Compare::Float(); +use Test2::Compare::Hash(); +use Test2::Compare::Isa(); +use Test2::Compare::Meta(); +use Test2::Compare::Number(); +use Test2::Compare::Object(); +use Test2::Compare::OrderedSubset(); +use Test2::Compare::Pattern(); +use Test2::Compare::Ref(); +use Test2::Compare::DeepRef(); +use Test2::Compare::Regex(); +use Test2::Compare::Scalar(); +use Test2::Compare::Set(); +use Test2::Compare::String(); +use Test2::Compare::Undef(); +use Test2::Compare::Wildcard(); + +%Carp::Internal = ( + %Carp::Internal, + 'Test2::Tools::Compare' => 1, + 'Test2::Compare::Array' => 1, + 'Test2::Compare::Bag' => 1, + 'Test2::Compare::Bool' => 1, + 'Test2::Compare::Custom' => 1, + 'Test2::Compare::Event' => 1, + 'Test2::Compare::Float' => 1, + 'Test2::Compare::Hash' => 1, + 'Test2::Compare::Isa' => 1, + 'Test2::Compare::Meta' => 1, + 'Test2::Compare::Number' => 1, + 'Test2::Compare::Object' => 1, + 'Test2::Compare::Pattern' => 1, + 'Test2::Compare::Ref' => 1, + 'Test2::Compare::Regex' => 1, + 'Test2::Compare::Scalar' => 1, + 'Test2::Compare::Set' => 1, + 'Test2::Compare::String' => 1, + 'Test2::Compare::Undef' => 1, + 'Test2::Compare::Wildcard' => 1, + 'Test2::Compare::OrderedSubset' => 1, +); + +our @EXPORT = qw/is like/; +our @EXPORT_OK = qw{ + is like isnt unlike + match mismatch validator + hash array bag object meta meta_check number float rounded within string subset bool check_isa + number_lt number_le number_ge number_gt + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event fail_events + exact_ref +}; +use base 'Exporter'; + +my $_autodump = sub { + my ($ctx, $got) = @_; + + my $module = $ENV{'T2_AUTO_DUMP'} or return; + $module = 'Data::Dumper' if $module eq '1'; + + my $file = pkg_to_file($module); + eval { require $file }; + + if (not $module->can('Dump')) { + require Data::Dumper; + $module = 'Data::Dumper'; + } + + my $deparse = $Data::Dumper::Deparse; + $deparse = !!$ENV{'T2_AUTO_DEPARSE'} if exists $ENV{'T2_AUTO_DEPARSE'}; + local $Data::Dumper::Deparse = $deparse; + + $ctx->diag($module->Dump([$got], ['GOT'])); +}; + +sub is($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my $delta = compare($got, $exp, \&strict_convert); + + if ($delta) { + # Temporary thing. + my $count = 0; + my $implicit = 0; + my @deltas = ($delta); + while (my $d = shift @deltas) { + my $add = $d->children; + push @deltas => @$add if $add && @$add; + next if $d->verified; + $count++; + $implicit++ if $d->note && $d->note eq 'implicit end'; + } + + if ($implicit == $count) { + $ctx->ok(1, $name); + my $meth = $ENV{AUTHOR_TESTING} ? 'throw' : 'alert'; + my $type = $delta->render_check; + $ctx->$meth( + join "\n", + "!!! NOTICE OF BEHAVIOR CHANGE !!!", + "This test uses at least 1 $type check without using end() or etc().", + "The old behavior was to default to etc() when inside is().", + "The old behavior was a bug.", + "The new behavior is to default to end().", + "This test will soon start to fail with the following diagnostics:", + $delta->diag->as_string, + "", + ); + } + else { + $ctx->fail($name, $delta->diag, @diag); + $ctx->$_autodump($got); + } + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; +} + +sub isnt($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my $delta = compare($got, $exp, \&strict_convert); + + if ($delta) { + $ctx->ok(1, $name); + } + else { + $ctx->ok(0, $name, ["Comparison matched (it should not).", @diag]); + $ctx->$_autodump($got); + } + + $ctx->release; + return $delta ? 1 : 0; +} + +sub like($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my $delta = compare($got, $exp, \&relaxed_convert); + + if ($delta) { + $ctx->fail($name, $delta->diag, @diag); + $ctx->$_autodump($got); + } + else { + $ctx->ok(1, $name); + } + + $ctx->release; + return !$delta; +} + +sub unlike($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + my $delta = compare($got, $exp, \&relaxed_convert); + + if ($delta) { + $ctx->ok(1, $name); + } + else { + $ctx->ok(0, $name, ["Comparison matched (it should not).", @diag]); + $ctx->$_autodump($got); + } + + $ctx->release; + return $delta ? 1 : 0; +} + +sub meta(&) { build('Test2::Compare::Meta', @_) } +sub meta_check(&) { build('Test2::Compare::Meta', @_) } +sub hash(&) { build('Test2::Compare::Hash', @_) } +sub array(&) { build('Test2::Compare::Array', @_) } +sub bag(&) { build('Test2::Compare::Bag', @_) } +sub object(&) { build('Test2::Compare::Object', @_) } +sub subset(&) { build('Test2::Compare::OrderedSubset', @_) } + +sub U() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { defined $_ ? 0 : 1 }, name => 'UNDEFINED', operator => '!DEFINED()', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub D() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { defined $_ ? 1 : 0 }, name => 'DEFINED', operator => 'DEFINED()', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub DF() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { defined $_ && ( ! ref $_ && ! $_ ) ? 1 : 0 }, name => 'DEFINED BUT FALSE', operator => 'DEFINED() && FALSE()', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub DNE() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { my %p = @_; $p{exists} ? 0 : 1 }, name => '', operator => '!exists', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub E() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { my %p = @_; $p{exists} ? 1 : 0 }, name => '', operator => '!exists', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub F() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { my %p = @_; $p{got} ? 0 : $p{exists} }, name => 'FALSE', operator => 'FALSE()', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub FDNE() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { + my %p = @_; + return 1 unless $p{exists}; + return $p{got} ? 0 : 1; + }, + name => 'FALSE', operator => 'FALSE() || !exists', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub T() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { + my %p = @_; + return 0 unless $p{exists}; + return $p{got} ? 1 : 0; + }, + name => 'TRUE', operator => 'TRUE()', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub L() { + my @caller = caller; + Test2::Compare::Custom->new( + code => sub { defined $_ && length $_ ? 1 : 0 }, name => 'LENGTH', operator => 'DEFINED() && LENGTH()', + file => $caller[1], + lines => [$caller[2]], + ); +} + +sub exact_ref($) { + my @caller = caller; + return Test2::Compare::Ref->new( + file => $caller[1], + lines => [$caller[2]], + input => $_[0], + ); +} + +sub match($) { + my @caller = caller; + return Test2::Compare::Pattern->new( + file => $caller[1], + lines => [$caller[2]], + pattern => $_[0], + ); +} + +sub mismatch($) { + my @caller = caller; + return Test2::Compare::Pattern->new( + file => $caller[1], + lines => [$caller[2]], + negate => 1, + pattern => $_[0], + ); +} + +sub validator { + my $code = pop; + my $cname = pop; + my $op = pop; + + my @caller = caller; + return Test2::Compare::Custom->new( + file => $caller[1], + lines => [$caller[2]], + code => $code, + name => $cname, + operator => $op, + ); +} + +sub number($;@) { + my ($num, @args) = @_; + my @caller = caller; + return Test2::Compare::Number->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + @args, + ); +} + +sub number_lt($;@) { + my ($num, @args) = @_; + my @caller = caller; + return Test2::Compare::Number->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + mode => '<', + @args, + ); +} + +sub number_le($;@) { + my ($num, @args) = @_; + my @caller = caller; + return Test2::Compare::Number->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + mode => '<=', + @args, + ); +} + +sub number_ge($;@) { + my ($num, @args) = @_; + my @caller = caller; + return Test2::Compare::Number->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + mode => '>=', + @args, + ); +} + +sub number_gt($;@) { + my ($num, @args) = @_; + my @caller = caller; + return Test2::Compare::Number->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + mode => '>', + @args, + ); +} + +sub float($;@) { + my ($num, @args) = @_; + my @caller = caller; + return Test2::Compare::Float->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + @args, + ); +} + +sub rounded($$) { + my ($num, $precision) = @_; + my @caller = caller; + return Test2::Compare::Float->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + precision => $precision, + ); +} + +sub within($;$) { + my ($num, $tolerance) = @_; + my @caller = caller; + return Test2::Compare::Float->new( + file => $caller[1], + lines => [$caller[2]], + input => $num, + defined $tolerance ? ( tolerance => $tolerance ) : (), + ); +} + +sub bool($;@) { + my ($bool, @args) = @_; + my @caller = caller; + return Test2::Compare::Bool->new( + file => $caller[1], + lines => [$caller[2]], + input => $bool, + @args, + ); +} + +sub string($;@) { + my ($str, @args) = @_; + my @caller = caller; + return Test2::Compare::String->new( + file => $caller[1], + lines => [$caller[2]], + input => $str, + @args, + ); +} + +sub check_isa($;@) { + my ($class_name, @args) = @_; + my @caller = caller; + return Test2::Compare::Isa->new( + file => $caller[1], + lines => [$caller[2]], + input => $class_name, + @args, + ); +} + +sub filter_items(&) { + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support filters" + unless $build->can('add_filter'); + + croak "'filter_items' should only ever be called in void context" + if defined wantarray; + + $build->add_filter(@_); +} + +sub all_items { + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support all-items" + unless $build->can('add_for_each'); + + croak "'all_items' should only ever be called in void context" + if defined wantarray; + + $build->add_for_each(@_); +} + +sub all_keys { + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support all-keys" + unless $build->can('add_for_each_key'); + + croak "'all_keys' should only ever be called in void context" + if defined wantarray; + + $build->add_for_each_key(@_); +} + +*all_vals = *all_values; +sub all_values { + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support all-values" + unless $build->can('add_for_each_val'); + + croak "'all_values' should only ever be called in void context" + if defined wantarray; + + $build->add_for_each_val(@_); +} + + +sub end() { + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support 'ending'" + unless $build->can('ending'); + + croak "'end' should only ever be called in void context" + if defined wantarray; + + $build->set_ending(1); +} + +sub etc() { + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support 'ending'" + unless $build->can('ending'); + + croak "'etc' should only ever be called in void context" + if defined wantarray; + + $build->set_ending(0); +} + +my $_call = sub { + my ($name, $expect, $context, $func_name) = @_; + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support method calls" + unless $build->can('add_call'); + + croak "'$func_name' should only ever be called in void context" + if defined wantarray; + + my @caller = caller; + $build->add_call( + $name, + Test2::Compare::Wildcard->new( + expect => $expect, + file => $caller[1], + lines => [$caller[2]], + ), + undef, + $context, + ); +}; + +sub call($$) { $_call->(@_,'scalar','call') } +sub call_list($$) { $_call->(@_,'list','call_list') } +sub call_hash($$) { $_call->(@_,'hash','call_hash') } + +sub prop($$) { + my ($name, $expect) = @_; + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support meta-checks" + unless $build->can('add_prop'); + + croak "'prop' should only ever be called in void context" + if defined wantarray; + + my @caller = caller; + $build->add_prop( + $name, + Test2::Compare::Wildcard->new( + expect => $expect, + file => $caller[1], + lines => [$caller[2]], + ), + ); +} + +sub item($;$) { + my @args = @_; + my $expect = pop @args; + + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support array item checks" + unless $build->can('add_item'); + + croak "'item' should only ever be called in void context" + if defined wantarray; + + my @caller = caller; + push @args => Test2::Compare::Wildcard->new( + expect => $expect, + file => $caller[1], + lines => [$caller[2]], + ); + + $build->add_item(@args); +} + +sub field($$) { + my ($name, $expect) = @_; + + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' does not support hash field checks" + unless $build->can('add_field'); + + croak "'field' should only ever be called in void context" + if defined wantarray; + + my @caller = caller; + $build->add_field( + $name, + Test2::Compare::Wildcard->new( + expect => $expect, + file => $caller[1], + lines => [$caller[2]], + ), + ); +} + +sub check($) { + my ($check) = @_; + + defined( my $build = get_build() ) or croak "No current build!"; + + croak "'$build' is not a check-set" + unless $build->can('add_check'); + + croak "'check' should only ever be called in void context" + if defined wantarray; + + my @caller = caller; + my $wc = Test2::Compare::Wildcard->new( + expect => $check, + file => $caller[1], + lines => [$caller[2]], + ); + + $build->add_check($wc); +} + +sub check_set { return _build_set('all' => @_) } +sub in_set { return _build_set('any' => @_) } +sub not_in_set { return _build_set('none' => @_) } + +sub _build_set { + my $redux = shift; + my ($builder) = @_; + my $btype = reftype($builder) || ''; + + my $set; + if ($btype eq 'CODE') { + $set = build('Test2::Compare::Set', $builder); + $set->set_builder($builder); + } + else { + $set = Test2::Compare::Set->new(checks => [@_]); + } + + $set->set_reduction($redux); + return $set; +} + +sub fail_events($;$) { + my $event = &event(@_); + + my $diag = event('Diag'); + + return ($event, $diag) if defined wantarray; + + defined( my $build = get_build() ) or croak "No current build!"; + $build->add_item($event); + $build->add_item($diag); +} + +sub event($;$) { + my ($intype, $spec) = @_; + + my @caller = caller; + + croak "type is required" unless $intype; + + my $type; + if ($intype =~ m/^\+(.*)$/) { + $type = $1; + } + else { + $type = "Test2::Event::$intype"; + } + + my $event; + if (!$spec) { + $event = Test2::Compare::Event->new( + etype => $intype, + file => $caller[1], + lines => [$caller[2]], + ending => 0, + ); + } + elsif (!ref $spec) { + croak "'$spec' is not a valid event specification"; + } + elsif (reftype($spec) eq 'CODE') { + $event = build('Test2::Compare::Event', $spec); + $event->set_etype($intype); + $event->set_builder($spec); + $event->set_ending(0) unless defined $event->ending; + } + else { + my $refcheck = Test2::Compare::Hash->new( + inref => $spec, + file => $caller[1], + lines => [$caller[2]], + ); + $event = Test2::Compare::Event->new( + refcheck => $refcheck, + file => $caller[1], + lines => [$caller[2]], + etype => $intype, + ending => 0, + ); + } + + $event->add_prop('blessed' => $type); + + return $event if defined wantarray; + + defined( my $build = get_build() ) or croak "No current build!"; + $build->add_item($event); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Compare - Tools for comparing deep data structures. + +=head1 DESCRIPTION + +L had C. This library is the L version that can +be used to compare data structures, but goes a step further in that it provides +tools for building a data structure specification against which you can verify +your data. There are both 'strict' and 'relaxed' versions of the tools. + +=head1 SYNOPSIS + + use Test2::Tools::Compare; + + # Hash for demonstration purposes + my $some_hash = {a => 1, b => 2, c => 3}; + + # Strict checking, everything must match + is( + $some_hash, + {a => 1, b => 2, c => 3}, + "The hash we got matches our expectations" + ); + + # Relaxed Checking, only fields we care about are checked, and we can use a + # regex to approximate a field. + like( + $some_hash, + {a => 1, b => qr/[0-9]+/}, + "'a' is 1, 'b' is an integer, we don't care about 'c'." + ); + +=head2 ADVANCED + +Declarative hash, array, and objects builders are available that allow you to +generate specifications. These are more verbose than simply providing a hash, +but have the advantage that every component you specify has a line number +associated. This is helpful for debugging as the failure output will tell you +not only which fields was incorrect, but also the line on which you declared +the field. + + use Test2::Tools::Compare qw{ + is like isnt unlike + match mismatch validator + hash array bag object meta number float rounded within string subset bool + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event fail_events + exact_ref + }; + + is( + $some_hash, + hash { + field a => 1; + field b => 2; + field c => 3; + }, + "Hash matches spec" + ); + +=head1 COMPARISON TOOLS + +=over 4 + +=item $bool = is($got, $expect) + +=item $bool = is($got, $expect, $name) + +=item $bool = is($got, $expect, $name, @diag) + +C<$got> is the data structure you want to check. C<$expect> is what you want +C<$got> to look like. C<$name> is an optional name for the test. C<@diag> is +optional diagnostics messages that will be printed to STDERR in event of +failure, they will not be displayed when the comparison is successful. The +boolean true/false result of the comparison is returned. + +This is the strict checker. The strict checker requires a perfect match between +C<$got> and C<$expect>. All hash fields must be specified, all array items must +be present, etc. All non-scalar/hash/array/regex references must be identical +(same memory address). Scalar, hash and array references will be traversed and +compared. Regex references will be compared to see if they have the same +pattern. + + is( + $some_hash, + {a => 1, b => 2, c => 3}, + "The hash we got matches our expectations" + ); + +The only exception to strictness is when it is given an C<$expect> object that +was built from a specification, in which case the specification determines the +strictness. Strictness only applies to literal values/references that are +provided and converted to a specification for you. + + is( + $some_hash, + hash { # Note: the hash function is not exported by default + field a => 1; + field b => match(qr/[0-9]+/); # Note: The match function is not exported by default + # Don't care about other fields. + }, + "The hash comparison is not strict" + ); + +This works for both deep and shallow structures. For instance you can use this +to compare two strings: + + is('foo', 'foo', "strings match"); + +B: This is not the tool to use if you want to check if two references are +the same exact reference, use C from the +L plugin instead. I of the time this will +work as well, however there are problems if your reference contains a cycle and +refers back to itself at some point. If this happens, an exception will be +thrown to break an otherwise infinite recursion. + +B: Non-reference values will be compared as strings using C, so that +means '2.0' and '2' will match. + +=item $bool = isnt($got, $expect) + +=item $bool = isnt($got, $expect, $name) + +=item $bool = isnt($got, $expect, $name, @diag) + +Opposite of C. Does all the same checks, but passes when there is a +mismatch. + +=item $bool = like($got, $expect) + +=item $bool = like($got, $expect, $name) + +=item $bool = like($got, $expect, $name, @diag) + +C<$got> is the data structure you want to check. C<$expect> is what you want +C<$got> to look like. C<$name> is an optional name for the test. C<@diag> is +optional diagnostics messages that will be printed to STDERR in event of +failure, they will not be displayed when the comparison is successful. The +boolean true/false result of the comparison is returned. + +This is the relaxed checker. This will ignore hash keys or array indexes that +you do not actually specify in your C<$expect> structure. In addition regex and +sub references will be used as validators. If you provide a regex using +C, the regex itself will be used to validate the corresponding value +in the C<$got> structure. The same is true for coderefs, the value is passed in +as the first argument (and in C<$_>) and the sub should return a boolean value. +In this tool regexes will stringify the thing they are checking. + + like( + $some_hash, + {a => 1, b => qr/[0-9]+/}, + "'a' is 1, 'b' is an integer, we don't care about other fields" + ); + +This works for both deep and shallow structures. For instance you can use this +to compare two strings: + + like('foo bar', qr/^foo/, "string matches the pattern"); + +=item $bool = unlike($got, $expect) + +=item $bool = unlike($got, $expect, $name) + +=item $bool = unlike($got, $expect, $name, @diag) + +Opposite of C. Does all the same checks, but passes when there is a +mismatch. + +=back + +The C, C, C, and C functions can be made +to dump C<$got> using L when tests fail by setting the +C environment variable to "1". (Alternatively, C +can be set to the name of a Perl module providing a compatible C +method.) The C environment variable can be used to +enable Data::Dumper's deparsing of coderefs. + +=head2 QUICK CHECKS + +B + +Quick checks are a way to quickly generate a common value specification. These +can be used in structures passed into C and C through the C<$expect> +argument. + +Example: + + is($foo, T(), '$foo has a true value'); + +=over 4 + +=item $check = T() + +This verifies that the value in the corresponding C<$got> structure is +true, any true value will do. + + is($foo, T(), '$foo has a true value'); + + is( + { a => 'xxx' }, + { a => T() }, + "The 'a' key is true" + ); + +=item $check = F() + +This verifies that the value in the corresponding C<$got> structure is +false, any false value will do, B. + + is($foo, F(), '$foo has a false value'); + + is( + { a => 0 }, + { a => F() }, + "The 'a' key is false" + ); + +It is important to note that a nonexistent value does not count as false. This +check will generate a failing test result: + + is( + { a => 1 }, + { a => 1, b => F() }, + "The 'b' key is false" + ); + +This will produce the following output: + + not ok 1 - The b key is false + # Failed test "The 'b' key is false" + # at some_file.t line 10. + # +------+------------------+-------+---------+ + # | PATH | GOT | OP | CHECK | + # +------+------------------+-------+---------+ + # | {b} | | FALSE | FALSE() | + # +------+------------------+-------+---------+ + +In Perl, you can have behavior that is different for a missing key vs. a false +key, so it was decided not to count a completely absent value as false. +See the C shortcut below for checking that a field is missing. + +If you want to check for false and/or DNE use the C check. + +=item $check = D() + +This is to verify that the value in the C<$got> structure is defined. Any value +other than C will pass. + +This will pass: + + is('foo', D(), 'foo is defined'); + +This will fail: + + is(undef, D(), 'foo is defined'); + +=item $check = U() + +This is to verify that the value in the C<$got> structure is undefined. + +This will pass: + + is(undef, U(), 'not defined'); + +This will fail: + + is('foo', U(), 'not defined'); + +=item $check = DF() + +This is to verify that the value in the C<$got> structure is defined but false. +Any false value other than C will pass. + +This will pass: + + is(0, DF(), 'foo is defined but false'); + +These will fail: + + is(undef, DF(), 'foo is defined but false'); + is(1, DF(), 'foo is defined but false'); + +=item $check = E() + +This can be used to check that a value exists. This is useful to check that an +array has more values, or to check that a key exists in a hash, even if the +value is undefined. + +These pass: + + is(['a', 'b', undef], ['a', 'b', E()], "There is a third item in the array"); + is({a => 1, b => 2}, {a => 1, b => E()}, "The 'b' key exists in the hash"); + +These will fail: + + is(['a', 'b'], ['a', 'b', E()], "Third item exists"); + is({a => 1}, {a => 1, b => E()}, "'b' key exists"); + +=item $check = DNE() + +This can be used to check that no value exists. This is useful to check the end +bound of an array, or to check that a key does not exist in a hash. + +These pass: + + is(['a', 'b'], ['a', 'b', DNE()], "There is no third item in the array"); + is({a => 1}, {a => 1, b => DNE()}, "The 'b' key does not exist in the hash"); + +These will fail: + + is(['a', 'b', 'c'], ['a', 'b', DNE()], "No third item"); + is({a => 1, b => 2}, {a => 1, b => DNE()}, "No 'b' key"); + +=item $check = FDNE() + +This is a combination of C and C. This will pass for a false value, +or a nonexistent value. + +=item $check = L() + +This is to verify that the value in the C<$got> structure is defined and +has length. Any value other than C or the empty string will pass +(including references). + +These will pass: + + is('foo', L(), 'value is defined and has length'); + is([], L(), 'value is defined and has length'); + +These will fail: + + is(undef, L(), 'value is defined and has length'); + is('', L(), 'value is defined and has length'); + +=back + +=head2 VALUE SPECIFICATIONS + +B + +=over 4 + +=item $check = string "..." + +Verify that the value matches the given string using the C operator. + +=item $check = !string "..." + +Verify that the value does not match the given string using the C operator. + +=item $check = number ...; + +Verify that the value matches the given number using the C<==> operator. + +=item $check = !number ...; + +Verify that the value does not match the given number using the C operator. + +=item $check = number_lt ...; + +=item $check = number_le ...; + +=item $check = number_ge ...; + +=item $check = number_gt ...; + +Verify that the value is less than, less than or equal to, greater than or +equal to, or greater than the given number. + +=item $check = float ...; + +Verify that the value is approximately equal to the given number. + +If a 'precision' parameter is specified, both operands will be +rounded to 'precision' number of fractional decimal digits and +compared with C. + + is($near_val, float($val, precision => 4), "Near 4 decimal digits"); + +Otherwise, the check will be made within a range of +/- 'tolerance', +with a default 'tolerance' of 1e-08. + + is( $near_val, float($val, tolerance => 0.01), "Almost there..."); + +See also C and C. + +=item $check = !float ...; + +Verify that the value is not approximately equal to the given number. + +If a 'precision' parameter is specified, both operands will be +rounded to 'precision' number of fractional decimal digits and +compared with C. + +Otherwise, the check will be made within a range of +/- 'tolerance', +with a default 'tolerance' of 1e-08. + +See also C and C. + +=item $check = within($num, $tolerance); + +Verify that the value approximately matches the given number, +within a range of +/- C<$tolerance>. Compared using the C<==> operator. + +C<$tolerance> is optional and defaults to 1e-08. + +=item $check = !within($num, $tolerance); + +Verify that the value does not approximately match the given number within a range of +/- C<$tolerance>. Compared using the C operator. + +C<$tolerance> is optional and defaults to 1e-08. + +=item $check = rounded($num, $precision); + +Verify that the value approximately matches the given number, when both are rounded to C<$precision> number of fractional digits. Compared using the C operator. + +=item $check = !rounded($num, $precision); + +Verify that the value does not approximately match the given number, when both are rounded to C<$precision> number of fractional digits. Compared using the C operator. + +=item $check = bool ...; + +Verify the value has the same boolean value as the given argument (XNOR). + +=item $check = !bool ...; + +Verify the value has a different boolean value from the given argument (XOR). + +=item $check = check_isa ...; + +Verify the value is an instance of the given class name. + +=item $check = !check_isa ...; + +Verify the value is not an instance of the given class name. + +=item $check = match qr/.../ + +=item $check = !mismatch qr/.../ + +Verify that the value matches the regex pattern. This form of pattern check +will B stringify references being checked. + +B C is documented for completion, please do not use it. + +=item $check = !match qr/.../ + +=item $check = mismatch qr/.../ + +Verify that the value does not match the regex pattern. This form of pattern +check will B stringify references being checked. + +B C was created before overloading of C for C +was a thing. + +=item $check = validator(sub{ ... }) + +=item $check = validator($NAME => sub{ ... }) + +=item $check = validator($OP, $NAME, sub{ ... }) + +The coderef is the only required argument. The coderef should check that the +value is what you expect and return a boolean true or false. Optionally, +you can specify a name and operator that are used in diagnostics. They are also +provided to the sub itself as named parameters. + +Check the value using this sub. The sub gets the value in C<$_>, and it +receives the value and several other items as named parameters. + + my $check = validator(sub { + my %params = @_; + + # These both work: + my $got = $_; + my $got = $params{got}; + + # Check if a value exists at all + my $exists = $params{exists} + + # What $OP (if any) did we specify when creating the validator + my $operator = $params{operator}; + + # What name (if any) did we specify when creating the validator + my $name = $params{name}; + + ... + + return $bool; + } + +=item $check = exact_ref($ref) + +Check that the value is exactly the same reference as the one provided. + +=back + +=head2 SET BUILDERS + +B + +=over 4 + +=item my $check = check_set($check1, $check2, ...) + +Check that the value matches ALL of the specified checks. + +=item my $check = in_set($check1, $check2, ...) + +Check that the value matches ONE OR MORE of the specified checks. + +=item not_in_set($check1, $check2, ...) + +Check that the value DOES NOT match ANY of the specified checks. + +=item check $thing + +Check that the value matches the specified thing. + +=back + +=head2 HASH BUILDER + +B + + $check = hash { + field foo => 1; + field bar => 2; + + # Ensure the 'baz' keys does not even exist in the hash. + field baz => DNE(); + + # Ensure the key exists, but is set to undef + field bat => undef; + + # Any check can be used + field boo => $check; + + # Set checks that apply to all keys or values. Can be done multiple + # times, and each call can define multiple checks, all will be run. + all_vals match qr/a/, match qr/b/; # All values must have an 'a' and a 'b' + all_keys match qr/x/; # All keys must have an 'x' + + ... + + end(); # optional, enforces that no other keys are present. + }; + +=over 4 + +=item $check = hash { ... } + +This is used to define a hash check. + +=item field $NAME => $VAL + +=item field $NAME => $CHECK + +Specify a field check. This will check the hash key specified by C<$NAME> and +ensure it matches the value in C<$VAL>. You can put any valid check in C<$VAL>, +such as the result of another call to C, C, etc. + +B This function can only be used inside a hash builder sub, and must be +called in void context. + +=item all_keys($CHECK1, $CHECK2, ...) + +Add checks that apply to all keys. You can put this anywhere in the hash +block, and can call it any number of times with any number of arguments. + +=item all_vals($CHECK1, $CHECK2, ...) + +=item all_values($CHECK1, $CHECK2, ...) + +Add checks that apply to all values. You can put this anywhere in the hash +block, and can call it any number of times with any number of arguments. + +=item end() + +Enforce that no keys are found in the hash other than those specified. This is +essentially the C of a hash check. This can be used anywhere in the +hash builder, though typically it is placed at the end. + +=item etc() + +Ignore any extra keys found in the hash. This is the opposite of C. +This can be used anywhere in the hash builder, though typically it is placed at +the end. + +=item DNE() + +This is a handy check that can be used with C to ensure that a field +(D)oes (N)ot (E)xist. + + field foo => DNE(); + +=back + +=head2 ARRAY BUILDER + +B + + $check = array { + # Uses the next index, in this case index 0; + item 'a'; + + # Gets index 1 automatically + item 'b'; + + # Specify the index + item 2 => 'c'; + + # We skipped index 3, which means we don't care what it is. + item 4 => 'e'; + + # Gets index 5. + item 'f'; + + # Remove any REMAINING items that contain 0-9. + filter_items { grep {!m/[0-9]/} @_ }; + + # Set checks that apply to all items. Can be done multiple times, and + # each call can define multiple checks, all will be run. + all_items match qr/a/, match qr/b/; + all_items match qr/x/; + + # Of the remaining items (after the filter is applied) the next one + # (which is now index 6) should be 'g'. + item 6 => 'g'; + + item 7 => DNE; # Ensure index 7 does not exist. + + end(); # Ensure no other indexes exist. + }; + +=over 4 + +=item $check = array { ... } + +=item item $VAL + +=item item $CHECK + +=item item $IDX, $VAL + +=item item $IDX, $CHECK + +Add an expected item to the array. If C<$IDX> is not specified it will +automatically calculate it based on the last item added. You can skip indexes, +which means you do not want them to be checked. + +You can provide any value to check in C<$VAL>, or you can provide any valid +check object. + +B Items MUST be added in order. + +B This function can only be used inside an array, bag or subset +builder sub, and must be called in void context. + +=item filter_items { my @remaining = @_; ...; return @filtered } + +This function adds a filter, all items remaining in the array from the point +the filter is reached will be passed into the filter sub as arguments, the sub +should return only the items that should be checked. + +B This function can only be used inside an array builder sub, and must +be called in void context. + +=item all_items($CHECK1, $CHECK2, ...) + +Add checks that apply to all items. You can put this anywhere in the array +block, and can call it any number of times with any number of arguments. + +=item end() + +Enforce that there are no indexes after the last one specified. This will not +force checking of skipped indexes. + +=item etc() + +Ignore any extra items found in the array. This is the opposite of C. +This can be used anywhere in the array builder, though typically it is placed +at the end. + +=item DNE() + +This is a handy check that can be used with C to ensure that an index +(D)oes (N)ot (E)xist. + + item 5 => DNE(); + +=back + +=head2 BAG BUILDER + +B + + $check = bag { + item 'a'; + item 'b'; + + end(); # Ensure no other elements exist. + }; + +A bag is like an array, but we don't care about the order of the +items. In the example, C<$check> would match both C<['a','b']> and +C<['b','a']>. + +=over 4 + +=item $check = bag { ... } + +=item item $VAL + +=item item $CHECK + +Add an expected item to the bag. + +You can provide any value to check in C<$VAL>, or you can provide any valid +check object. + +B This function can only be used inside an array, bag or subset +builder sub, and must be called in void context. + +=item all_items($CHECK1, $CHECK2, ...) + +Add checks that apply to all items. You can put this anywhere in the bag +block, and can call it any number of times with any number of arguments. + +=item end() + +Enforce that there are no more items after the last one specified. + +=item etc() + +Ignore any extra items found in the array. This is the opposite of C. +This can be used anywhere in the bag builder, though typically it is placed +at the end. + +=back + +=head2 ORDERED SUBSET BUILDER + +B + + $check = subset { + item 'a'; + item 'b'; + item 'c'; + + # Doesn't matter if the array has 'd', the check will skip past any + # unknown items until it finds the next one in our subset. + + item 'e'; + item 'f'; + }; + +=over 4 + +=item $check = subset { ... } + +=item item $VAL + +=item item $CHECK + +Add an expected item to the subset. + +You can provide any value to check in C<$VAL>, or you can provide any valid +check object. + +B Items MUST be added in order. + +B This function can only be used inside an array, bag or subset +builder sub, and must be called in void context. + +=back + +=head2 META BUILDER + +B + + my $check = meta { + prop blessed => 'My::Module'; # Ensure value is blessed as our package + prop reftype => 'HASH'; # Ensure value is a blessed hash + prop isa => 'My::Base'; # Ensure value is an instance of our class + prop size => 4; # Check the number of hash keys + prop this => ...; # Check the item itself + }; + +=over 4 + +=item meta { ... } + +=item meta_check { ... } + +Build a meta check. If you are using L then the C function would +conflict with the one exported by L, in such cases C is +available. Neither is exported by default. + +=item prop $NAME => $VAL + +=item prop $NAME => $CHECK + +Check the property specified by C<$name> against the value or check. + +Valid properties are: + +=over 4 + +=item 'blessed' + +What package (if any) the thing is blessed as. + +=item 'reftype' + +Reference type (if any) the thing is. + +=item 'isa' + +What class the thing is an instance of. + +=item 'this' + +The thing itself. + +=item 'size' + +For array references this returns the number of elements. For hashes this +returns the number of keys. For everything else this returns undef. + +=back + +=back + +=head2 OBJECT BUILDER + +B + + my $check = object { + call foo => 1; # Call the 'foo' method, check the result. + + # Call the specified sub-ref as a method on the object, check the + # result. This is useful for wrapping methods that return multiple + # values. + call sub { [ shift->get_list ] } => [...]; + + # This can be used to ensure a method does not exist. + call nope => DNE(); + + # Check the hash key 'foo' of the underlying reference, this only works + # on blessed hashes. + field foo => 1; + + # Check the value of index 4 on the underlying reference, this only + # works on blessed arrays. + item 4 => 'foo'; + + # Check the meta-property 'blessed' of the object. + prop blessed => 'My::Module'; + + # Check if the object is an instance of the specified class. + prop isa => 'My::Base'; + + # Ensure only the specified hash keys or array indexes are present in + # the underlying hash. Has no effect on meta-property checks or method + # checks. + end(); + }; + +=over 4 + +=item $check = object { ... } + +Specify an object check for use in comparisons. + +=item call $METHOD_NAME => $RESULT + +=item call $METHOD_NAME => $CHECK + +=item call [$METHOD_NAME, @METHOD_ARGS] => $RESULT + +=item call [$METHOD_NAME, @METHOD_ARGS] => $CHECK + +=item call sub { ... }, $RESULT + +=item call sub { ... }, $CHECK + +Call the specified method (or coderef) and verify the result. If you +pass an arrayref, the first element must be the method name, the +others are the arguments it will be called with. + +The coderef form is useful if you need to do something more complex. + + my $ref = sub { + local $SOME::GLOBAL::THING = 3; + return [shift->get_values_for('thing')]; + }; + + call $ref => ...; + +=item call_list $METHOD_NAME => $RESULT + +=item call_list $METHOD_NAME => $CHECK + +=item call_list [$METHOD_NAME, @METHOD_ARGS] => $RESULT + +=item call_list [$METHOD_NAME, @METHOD_ARGS] => $CHECK + +=item call_list sub { ... }, $RESULT + +=item call_list sub { ... }, $CHECK + +Same as C, but the method is invoked in list context, and the +result is always an arrayref. + + call_list get_items => [ ... ]; + +=item call_hash $METHOD_NAME => $RESULT + +=item call_hash $METHOD_NAME => $CHECK + +=item call_hash [$METHOD_NAME, @METHOD_ARGS] => $RESULT + +=item call_hash [$METHOD_NAME, @METHOD_ARGS] => $CHECK + +=item call_hash sub { ... }, $RESULT + +=item call_hash sub { ... }, $CHECK + +Same as C, but the method is invoked in list context, and the +result is always a hashref. This will warn if the method returns an +odd number of values. + + call_hash get_items => { ... }; + +=item field $NAME => $VAL + +Works just like it does for hash checks. + +=item item $VAL + +=item item $IDX, $VAL + +Works just like it does for array checks. + +=item prop $NAME => $VAL + +=item prop $NAME => $CHECK + +Check the property specified by C<$name> against the value or check. + +Valid properties are: + +=over 4 + +=item 'blessed' + +What package (if any) the thing is blessed as. + +=item 'reftype' + +Reference type (if any) the thing is. + +=item 'isa' + +What class the thing is an instance of. + +=item 'this' + +The thing itself. + +=item 'size' + +For array references this returns the number of elements. For hashes this +returns the number of keys. For everything else this returns undef. + +=back + +=item DNE() + +Can be used with C, or C to ensure the hash field or array index +does not exist. Can also be used with C to ensure a method does not +exist. + +=item end() + +Turn on strict array/hash checking, ensuring that no extra keys/indexes +are present. + +=item etc() + +Ignore any extra items found in the hash/array. This is the opposite of +C. This can be used anywhere in the builder, though typically it is +placed at the end. + +=back + +=head2 EVENT BUILDERS + +B + +Check that we got an event of a specified type: + + my $check = event 'Ok'; + +Check for details about the event: + + my $check = event Ok => sub { + # Check for a failure + call pass => 0; + + # Effective pass after TODO/SKIP are accounted for. + call effective_pass => 1; + + # Check the diagnostics + call diag => [ match qr/Failed test foo/ ]; + + # Check the file the event reports to + prop file => 'foo.t'; + + # Check the line number the event reports o + prop line => '42'; + + # You can check the todo/skip values as well: + prop skip => 'broken'; + prop todo => 'fixme'; + + # Thread-id and process-id where event was generated + prop tid => 123; + prop pid => 123; + }; + +You can also provide a fully qualified event package with the '+' prefix: + + my $check = event '+My::Event' => sub { ... } + +You can also provide a hashref instead of a sub to directly check hash values +of the event: + + my $check = event Ok => { pass => 1, ... }; + +=head3 USE IN OTHER BUILDERS + +You can use these all in other builders, simply use them in void context to +have their value(s) appended to the build. + + my $check = array { + event Ok => { ... }; + event Note => { ... }; + + fail_events Ok => { pass => 0 }; + # Get a Diag for free. + }; + +=head3 SPECIFICS + +=over 4 + +=item $check = event $TYPE; + +=item $check = event $TYPE => sub { ... }; + +=item $check = event $TYPE => { ... }; + +This works just like an object builder. In addition to supporting everything +the object check supports, you also have to specify the event type, and many +extra meta-properties are available. + +Extra properties are: + +=over 4 + +=item 'file' + +File name to which the event reports (for use in diagnostics). + +=item 'line' + +Line number to which the event reports (for use in diagnostics). + +=item 'package' + +Package to which the event reports (for use in diagnostics). + +=item 'subname' + +Sub that was called to generate the event (example: C). + +=item 'skip' + +Set to the skip value if the result was generated by skipping tests. + +=item 'todo' + +Set to the todo value if TODO was set when the event was generated. + +=item 'trace' + +The C string that will be used in diagnostics. + +=item 'tid' + +Thread ID in which the event was generated. + +=item 'pid' + +Process ID in which the event was generated. + +=back + +B: Event checks have an implicit C added. This means you need to +use C if you want to fail on unexpected hash keys or array indexes. This +implicit C extends to all forms, including builder, hashref, and no +argument. + +=item @checks = fail_events $TYPE; + +=item @checks = fail_events $TYPE => sub { ... }; + +=item @checks = fail_events $TYPE => { ... }; + +Just like C documented above. The difference is that this produces two +events, the one you specify, and a C after it. There are no extra checks +in the Diag. + +Use this to validate a simple failure where you do not want to be bothered with +the default diagnostics. It only adds a single Diag check, so if your failure +has custom diagnostics you will need to add checks for them. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Defer.pm b/cpan/Test2-Suite/lib/Test2/Tools/Defer.pm new file mode 100644 index 000000000000..b424e3d6d883 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Defer.pm @@ -0,0 +1,173 @@ +package Test2::Tools::Defer; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; + +use Test2::Util qw/get_tid/; +use Test2::API qw{ + test2_add_callback_exit + test2_pid test2_tid +}; + +our @EXPORT = qw/def do_def/; +use base 'Exporter'; + +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; + + chomp(my $eval = <<" EOT"); +package $pkg; +# line $line "(eval in Test2::Tools::Defer) $file" +\&$func(\@\$args); +1; + EOT + + eval $eval and next; + chomp(my $error = $@); + + require Data::Dumper; + chomp(my $td = Data::Dumper::Dumper($args)); + $td =~ s/^\$VAR1 =/\$args: /; + die <<" EOT"; +Exception: $error +--eval-- +$eval +-------- +Tool: $func +Caller: $caller->[0], $caller->[1], $caller->[2] +$td + EOT + } + + return; +} + +sub _verify { + my ($context, $exit, $new_exit) = @_; + + my $not_ok = 0; + for my $pkg (keys %TODO) { + my $tests = delete $TODO{$pkg}; + my $caller = $tests->[0]->[-1]; + print STDOUT "not ok - deferred tests were not run!\n" unless $not_ok++; + print STDERR "# '$pkg' has deferred tests that were never run!\n"; + print STDERR "# $caller->[1] at line $caller->[2]\n"; + $$new_exit ||= 255; + } +} + +test2_add_callback_exit(\&_verify); + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Defer - Write tests that get executed at a later time + +=head1 DESCRIPTION + +Sometimes you need to test things BEFORE loading the necessary functions. This +module lets you do that. You can write tests, and then have them run later, +after C is loaded. You tell it what test function to run, and what +arguments to give it. The function name and arguments will be stored to be +executed later. When ready, run C to kick them off once the functions +are defined. + +=head1 SYNOPSIS + + use strict; + use warnings; + + use Test2::Tools::Defer; + + BEGIN { + def ok => (1, 'pass'); + def is => ('foo', 'foo', 'runs is'); + ... + } + + use Test2::Tools::Basic; + + do_def(); # Run the tests + + # Declare some more tests to run later: + def ok => (1, "another pass"); + ... + + do_def(); # run the new tests + + done_testing; + +=head1 EXPORTS + +=over 4 + +=item def function => @args; + +This will store the function name, and the arguments to be run later. Note that +each package has a separate store of tests to run. + +=item do_def() + +This will run all the stored tests. It will also reset the list to be empty so +you can add more tests to run even later. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Encoding.pm b/cpan/Test2-Suite/lib/Test2/Tools/Encoding.pm new file mode 100644 index 000000000000..1a1a99ce6351 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Encoding.pm @@ -0,0 +1,94 @@ +package Test2::Tools::Encoding; +use strict; +use warnings; + +use Carp qw/croak/; + +use Test2::API qw/test2_stack/; + +use base 'Exporter'; + +our $VERSION = '0.000156'; + +our @EXPORT = qw/set_encoding/; + +sub set_encoding { + my $enc = shift; + my $format = test2_stack->top->format; + + unless ($format && eval { $format->can('encoding') }) { + $format = '' unless defined $format; + croak "Unable to set encoding on formatter '$format'"; + } + + $format->encoding($enc); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Encoding - Tools for managing the encoding of L based +tests. + +=head1 DESCRIPTION + +This module exports a function that lets you dynamically change the output +encoding at will. + +=head1 SYNOPSIS + + use Test2::Tools::Encoding; + + set_encoding('utf8'); + +=head1 EXPORTS + +All subs are exported by default. + +=over 4 + +=item set_encoding($encoding) + +This will set the encoding to whatever you specify. This will only affect the +output of the current formatter, which is usually your TAP output formatter. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Event.pm b/cpan/Test2-Suite/lib/Test2/Tools/Event.pm new file mode 100644 index 000000000000..eeb9f896069a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Event.pm @@ -0,0 +1,95 @@ +package Test2::Tools::Event; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Util qw/pkg_to_file/; + +our @EXPORT = qw/gen_event/; +use base 'Exporter'; + +sub gen_event { + my ($type, %fields) = @_; + + $type = "Test2::Event::$type" unless $type =~ s/^\+//; + + require(pkg_to_file($type)); + + $fields{trace} ||= Test2::Util::Trace->new(frame => [caller(0)]); + + return $type->new(%fields); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Event - Tools for generating test events. + +=head1 DESCRIPTION + +This module provides tools for generating events quickly by bypassing the +context/hub. This is particularly useful when testing other L packages. + +=head1 EXPORTS + +=over 4 + +=item $e = gen_event($TYPE) + +=item $e = gen_event($TYPE, %FIELDS) + +=item $e = gen_event 'Ok'; + +=item $e = gen_event Ok => ( ... ) + +=item $e = gen_event '+Test2::Event::Ok' => ( ... ) + +This will produce an event of the specified type. C<$TYPE> is assumed to be +shorthand for C, you can prefix C<$TYPE> with a '+' to +drop the assumption. + +An L will be generated using C and will be put in +the 'trace' field of your new event, unless you specified your own 'trace' +field. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Exception.pm b/cpan/Test2-Suite/lib/Test2/Tools/Exception.pm new file mode 100644 index 000000000000..80fad6f81bac --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Exception.pm @@ -0,0 +1,169 @@ +package Test2::Tools::Exception; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/carp/; +use Test2::API qw/context/; + +our @EXPORT = qw/dies lives try_ok/; +use base 'Exporter'; + +sub dies(&) { + my $code = shift; + + defined wantarray or carp "Useless use of dies() in void context"; + + local ($@, $!, $?); + my $ok = eval { $code->(); 1 }; + my $err = $@; + + return undef if $ok; + + unless ($err) { + my $ctx = context(); + $ctx->alert("Got exception as expected, but exception is falsy (undef, '', or 0)..."); + $ctx->release; + } + + return $err; +} + +sub lives(&) { + my $code = shift; + + defined wantarray or carp "Useless use of lives() in void context"; + + my $err; + { + local ($@, $!, $?); + eval { $code->(); 1 } and return 1; + $err = $@; + } + + # If the eval failed we want to set $@ to the error. + $@ = $err; + return 0; +} + +sub try_ok(&;$) { + my ($code, $name) = @_; + + my $ok = &lives($code); + my $err = $@; + + # Context should be obtained AFTER code is run so that events inside the + # codeblock report inside the codeblock itself. This will also preserve $@ + # as thrown inside the codeblock. + my $ctx = context(); + chomp(my $diag = "Exception: $err"); + $ctx->ok($ok, $name, [$diag]); + $ctx->release; + + $@ = $err unless $ok; + return $ok; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Exception - Test2 based tools for checking exceptions + +=head1 DESCRIPTION + +This is the L implementation of code used to test exceptions. This is +similar to L, but it intentionally does much less. + +=head1 SYNOPSIS + + use Test2::Tools::Exception qw/dies lives/; + + like( + dies { die 'xxx' }, + qr/xxx/, + "Got exception" + ); + + ok(lives { ... }, "did not die") or note($@); + +=head1 EXPORTS + +All subs are exported by default. + +=over 4 + +=item $e = dies { ... } + +This will trap any exception the codeblock throws. If no exception is thrown +the sub will return undef. If an exception is thrown it will be returned. This +function preserves C<$@>, it will not be altered from its value before the sub +is called. + +=item $bool = lives { ... } + +This will trap any exception thrown in the codeblock. It will return true when +there is no exception, and false when there is. C<$@> is preserved from before +the sub is called when there is no exception. When an exception is trapped +C<$@> will have the exception so that you can look at it. + +=item $bool = try_ok { ... } + +=item $bool = try_ok { ... } "Test Description" + +This will run the code block trapping any exception. If there is no exception a +passing event will be issued. If the test fails a failing event will be issued, +and the exception will be reported as diagnostics. + +B This function does not preserve C<$@> on failure, it will be set to +the exception the codeblock throws, this is by design so that you can obtain +the exception if desired. + +=back + +=head1 DIFFERENCES FROM TEST::FATAL + +L sets C<$Test::Builder::Level> such that failing tests inside the +exception block will report to the line where C is called. I +disagree with this, and think the actual line of the failing test is +more important. Ultimately, though L cannot be changed, people +probably already depend on that behavior. + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Exports.pm b/cpan/Test2-Suite/lib/Test2/Tools/Exports.pm new file mode 100644 index 000000000000..9087a20b81f5 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Exports.pm @@ -0,0 +1,169 @@ +package Test2::Tools::Exports; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak carp/; +use Test2::API qw/context/; +use Test2::Util::Stash qw/get_symbol/; + +our @EXPORT = qw/imported_ok not_imported_ok/; +use base 'Exporter'; + +sub imported_ok { + my $ctx = context(); + my $caller = caller; + my @missing = grep { !get_symbol($_, $caller) } @_; + + my $name = "Imported symbol"; + $name .= "s" if @_ > 1; + $name .= ": "; + my $list = join(", ", @_); + substr($list, 37, length($list) - 37, '...') if length($list) > 40; + $name .= $list; + + $ctx->ok(!@missing, $name, [map { "'$_' was not imported." } @missing]); + + $ctx->release; + + return !@missing; +} + +sub not_imported_ok { + my $ctx = context(); + my $caller = caller; + my @found = grep { get_symbol($_, $caller) } @_; + + my $name = "Did not imported symbol"; + $name .= "s" if @_ > 1; + $name .= ": "; + my $list = join(", ", @_); + substr($list, 37, length($list) - 37, '...') if length($list) > 40; + $name .= $list; + + $ctx->ok(!@found, $name, [map { "'$_' was imported." } @found]); + + $ctx->release; + + return !@found; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Exports - Tools for validating exporters. + +=head1 DESCRIPTION + +These are tools for checking that symbols have been imported into your +namespace. + +=head1 SYNOPSIS + + use Test2::Tools::Exports + + use Data::Dumper; + imported_ok qw/Dumper/; + not_imported_ok qw/dumper/; + +=head1 EXPORTS + +All subs are exported by default. + +=over 4 + +=item imported_ok(@SYMBOLS) + +Check that the specified symbols exist in the current package. This will not +find inherited subs. This will only find symbols in the current package's symbol +table. This B confirm that the symbols were defined outside of the +package itself. + + imported_ok( '$scalar', '@array', '%hash', '&sub', 'also_a_sub' ); + +C<@SYMBOLS> can contain any number of symbols. Each item in the array must be a +string. The string should be the name of a symbol. If a sigil is present then +it will search for that specified type, if no sigil is specified it will be +used as a sub name. + +=item not_imported_ok(@SYMBOLS) + +Check that the specified symbols do not exist in the current package. This will +not find inherited subs. This will only look at symbols in the current package's +symbol table. + + not_imported_ok( '$scalar', '@array', '%hash', '&sub', 'also_a_sub' ); + +C<@SYMBOLS> can contain any number of symbols. Each item in the array must be a +string. The string should be the name of a symbol. If a sigil is present, then +it will search for that specified type. If no sigil is specified, it will be +used as a sub name. + +=back + +=head1 CAVEATS + +Before Perl 5.10, it is very difficult to distinguish between a package scalar +that is undeclared vs declared and undefined. Currently C and +C cannot see package scalars declared using C unless +the variable has been assigned a defined value. + +This will pass on recent perls, but fail on perls older than 5.10: + + use Test2::Tools::Exports; + + our $foo; + + # Fails on perl onlder than 5.10 + imported_ok(qw/$foo/); + +If C<$foo> is imported from another module, or imported using +C then it will work on all supported perl versions. + + use Test2::Tools::Exports; + + use vars qw/$foo/; + use Some::Module qw/$bar/; + + # Always works + imported_ok(qw/$foo $bar/); + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/GenTemp.pm b/cpan/Test2-Suite/lib/Test2/Tools/GenTemp.pm new file mode 100644 index 000000000000..10c20751029e --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/GenTemp.pm @@ -0,0 +1,125 @@ +package Test2::Tools::GenTemp; + +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use File::Temp qw/tempdir/; +use File::Spec; + +our @EXPORT = qw{gen_temp}; +use base 'Exporter'; + +sub gen_temp { + my %args = @_; + + my $tempdir_args = delete $args{'-tempdir'} || [CLEANUP => 1, TMPDIR => 1]; + + my $tmp = tempdir(@$tempdir_args); + + gen_dir($tmp, \%args); + + return $tmp; +} + +sub gen_dir { + my ($dir, $content) = @_; + + for my $path (keys %$content) { + my $fq = File::Spec->catfile($dir, $path); + my $inside = $content->{$path}; + + if (ref $inside) { + # Subdirectory + mkdir($fq) or die "Could not make dir '$fq': $!"; + gen_dir($fq, $inside); + } + else { + open(my $fh, '>', $fq) or die "Could not open file '$fq' for writing: $!"; + print $fh $inside; + close($fh); + } + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::GenTemp - Tool for generating a populated temp directory. + +=head1 DESCRIPTION + +This exports a tool that helps you make a temporary directory, nested +directories and text files within. + +=head1 SYNOPSIS + + use Test2::Tools::GenTemp qw/gen_temp/; + + my $dir = gen_temp( + a_file => "Contents of a_file", + a_dir => { + 'a_file' => 'Contents of a_dir/afile', + a_nested_dir => { ... }, + }, + ... + ); + + done_testing; + +=head1 EXPORTS + +All subs are exported by default. + +=over 4 + +=item gen_temp(file => 'content', subdir => [ sub_dir_file => 'content', ...], ...) + +=item gen_temp(-tempdir => \@TEMPDIR_ARGS, file => 'content', subdir => [ sub_dir_file => 'content', ...], ...) + +This will generate a new temporary directory with all the files and subdirs you +specify, recursively. The initial temp directory is created using +C, you may pass arguments to tempdir using the +C<< -tempdir => [...] >> argument. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Grab.pm b/cpan/Test2-Suite/lib/Test2/Tools/Grab.pm new file mode 100644 index 000000000000..7e7e74654d71 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Grab.pm @@ -0,0 +1,124 @@ +package Test2::Tools::Grab; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Util::Grabber; +use Test2::EventFacet::Trace(); + +our @EXPORT = qw/grab/; +use base 'Exporter'; + +sub grab { Test2::Util::Grabber->new(trace => Test2::EventFacet::Trace->new(frame => [caller(0)]) ) } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Grab - Temporarily intercept all events without adding a scope +level. + +=head1 DESCRIPTION + +This package provides a function that returns an object that grabs all events. +Once the object is destroyed events will once again be sent to the main hub. + +=head1 SYNOPSIS + + use Test2::Tools::Grab; + + my $grab = grab(); + + # Generate some events, they are intercepted. + ok(1, "pass"); + ok(0, "fail"); + + my $events_a = $grab->flush; + + # Generate some more events, they are intercepted. + ok(1, "pass"); + ok(0, "fail"); + + my $events_b = $grab->finish; + +=head1 EXPORTS + +=over 4 + +=item $grab = grab() + +This lets you intercept all events for a section of code without adding +anything to your call stack. This is useful for things that are sensitive to +changes in the stack depth. + + my $grab = grab(); + ok(1, 'foo'); + ok(0, 'bar'); + + my $events = $grab->finish; + + is(@$events, 2, "grabbed 2 events."); + +If the C<$grab> object is destroyed without calling C, it will +automatically clean up after itself and restore the parent hub. + + { + my $grab = grab(); + # Things are grabbed + } + # Things are back to normal + +By default the hub used has C set to true. This will prevent the hub +from enforcing that you issued a plan and ran at least 1 test. You can turn +enforcement back one like this: + + $grab->hub->set_no_ending(0); + +With C turned off, C will run the post-test checks to +enforce the plan and that tests were run. In many cases this will result in +additional events in your events array. + +=back + +=head1 SEE ALSO + +L - The object constructed and returned by this tool. + +=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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Mock.pm b/cpan/Test2-Suite/lib/Test2/Tools/Mock.pm new file mode 100644 index 000000000000..841df1523373 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Mock.pm @@ -0,0 +1,541 @@ +package Test2::Tools::Mock; +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/blessed reftype weaken/; +use Test2::Util qw/try/; +use Test2::Util::Sub qw/gen_accessor gen_reader gen_writer/; + +use Test2::Mock(); + +use base 'Exporter'; + +our $VERSION = '0.000156'; + +our @CARP_NOT = (__PACKAGE__, 'Test2::Mock'); +our @EXPORT = qw/mock mocked/; +our @EXPORT_OK = qw{ + mock_obj mock_class + mock_do mock_build + mock_accessor mock_accessors + mock_getter mock_getters + mock_setter mock_setters + mock_building +}; + +my %HANDLERS; +my %MOCKS; +my @BUILD; + +sub add_handler { + my $class = shift; + my ($for, $code) = @_; + + croak "Must specify a package for the mock handler" + unless $for; + + croak "Handlers must be code referneces (got: $code)" + unless $code && ref($code) eq 'CODE'; + + push @{$HANDLERS{$for}} => $code; +} + +sub mock_building { + return unless @BUILD; + return $BUILD[-1]; +} + +sub mocked { + my $proto = shift; + my $class = blessed($proto) || $proto; + + # Check if we have any mocks. + my $set = $MOCKS{$class} || return; + + # Remove dead mocks (undef due to weaken) + pop @$set while @$set && !defined($set->[-1]); + + # Remove the list if it is empty + delete $MOCKS{$class} unless @$set; + + # Return the controls (may be empty list) + return @$set; +} + +sub _delegate { + my ($args) = @_; + + my $do = __PACKAGE__->can('mock_do'); + my $obj = __PACKAGE__->can('mock_obj'); + my $class = __PACKAGE__->can('mock_class'); + my $build = __PACKAGE__->can('mock_build'); + + return $obj unless @$args; + + my ($proto, $arg1) = @$args; + + return $obj if ref($proto) && !blessed($proto); + + if (blessed($proto)) { + return $class unless $proto->isa('Test2::Mock'); + return $build if $arg1 && ref($arg1) && reftype($arg1) eq 'CODE'; + } + + return $class if $proto =~ m/(?:::|')/; + return $class if $proto =~ m/^_*[A-Z]/; + + return $do if Test2::Mock->can($proto); + + if (my $sub = __PACKAGE__->can("mock_$proto")) { + shift @$args; + return $sub; + } + + return undef; +} + +sub mock { + croak "undef is not a valid first argument to mock()" + if @_ && !defined($_[0]); + + my $sub = _delegate(\@_); + + croak "'$_[0]' does not look like a package name, and is not a valid control method" + unless $sub; + + $sub->(@_); +} + +sub mock_build { + my ($control, $sub) = @_; + + croak "mock_build requires a Test2::Mock object as its first argument" + unless $control && blessed($control) && $control->isa('Test2::Mock'); + + croak "mock_build requires a coderef as its second argument" + unless $sub && ref($sub) && reftype($sub) eq 'CODE'; + + push @BUILD => $control; + my ($ok, $err) = &try($sub); + pop @BUILD; + die $err unless $ok; +} + +sub mock_do { + my ($meth, @args) = @_; + + croak "Not currently building a mock" + unless @BUILD; + + my $build = $BUILD[-1]; + + croak "'$meth' is not a valid action for mock_do()" + if $meth =~ m/^_/ || !$build->can($meth); + + $build->$meth(@args); +} + +sub mock_obj { + my ($proto) = @_; + + if ($proto && ref($proto) && reftype($proto) ne 'CODE') { + shift @_; + } + else { + $proto = {}; + } + + my $class = _generate_class(); + my $control; + + if (@_ == 1 && reftype($_[0]) eq 'CODE') { + my $orig = shift @_; + $control = mock_class( + $class, + sub { + my $c = mock_building; + + # We want to do these BEFORE anything that the sub may do. + $c->block_load(1); + $c->purge_on_destroy(1); + $c->autoload(1); + + $orig->(@_); + }, + ); + } + else { + $control = mock_class( + $class, + # Do these before anything the user specified. + block_load => 1, + purge_on_destroy => 1, + autoload => 1, + @_, + ); + } + + my $new = bless($proto, $control->class); + + # We need to ensure there is a reference to the control object, and we want + # it to go away with the object. + $new->{'~~MOCK~CONTROL~~'} = $control; + return $new; +} + +sub _generate_class { + my $prefix = __PACKAGE__; + + for (1 .. 100) { + my $postfix = join '', map { chr(rand(26) + 65) } 1 .. 32; + my $class = $prefix . '::__TEMP__::' . $postfix; + my $file = $class; + $file =~ s{::}{/}g; + $file .= '.pm'; + next if $INC{$file}; + my $stash = do { no strict 'refs'; \%{"${class}\::"} }; + next if keys %$stash; + return $class; + } + + croak "Could not generate a unique class name after 100 attempts"; +} + +sub mock_class { + my $proto = shift; + my $class = blessed($proto) || $proto; + my @args = @_; + + my $void = !defined(wantarray); + + my $callback = sub { + my ($parent) = reverse mocked($class); + my $control; + + if (@args == 1 && ref($args[0]) && reftype($args[0]) eq 'CODE') { + $control = Test2::Mock->new(class => $class); + mock_build($control, @args); + } + else { + $control = Test2::Mock->new(class => $class, @args); + } + + if ($parent) { + $control->{parent} = $parent; + weaken($parent->{child} = $control); + } + + $MOCKS{$class} ||= []; + push @{$MOCKS{$class}} => $control; + weaken($MOCKS{$class}->[-1]); + + return $control; + }; + + return $callback->() unless $void; + + my $level = 0; + my $caller; + while (my @call = caller($level++)) { + next if $call[0] eq __PACKAGE__; + $caller = \@call; + last; + } + + my $handled; + for my $handler (@{$HANDLERS{$caller->[0]}}) { + $handled++ if $handler->( + class => $class, + caller => $caller, + builder => $callback, + args => \@args, + ); + } + + croak "mock_class should not be called in a void context without a registered handler" + unless $handled; +} + +sub mock_accessors { + return map {( $_ => gen_accessor($_) )} @_; +} + +sub mock_accessor { + my ($field) = @_; + return gen_accessor($field); +} + +sub mock_getters { + my ($prefix, @list) = @_; + return map {( "$prefix$_" => gen_reader($_) )} @list; +} + +sub mock_getter { + my ($field) = @_; + return gen_reader($field); +} + +sub mock_setters { + my ($prefix, @list) = @_; + return map {( "$prefix$_" => gen_writer($_) )} @list; +} + +sub mock_setter { + my ($field) = @_; + return gen_writer($field); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Mock - Class/Instance mocking for Test2. + +=head1 DESCRIPTION + +Mocking is often an essential part of testing. This library covers some of the +most common mocking needs. This plugin is heavily influenced by L, +but with an improved API. This plugin is also intended to play well with other +plugins in ways L would be unable to. + +=head1 SYNOPSIS + + my $mock = mock 'Some::Class' => ( + track => $BOOL, # Enable/Disable tracking on subs defined below + + add => [ + new_method => sub { ... }, + ], + override => [ + replace_method => sub { ... }, + ], + set => [ + replace_or_inject => sub { ... }, + ], + + track => $bool, # enable/disable tracking again to affect mocks made after this point + ..., # Argument keys may be repeated + ); + + Some::Class->new_method(); # Calls the newly injected method + Some::Class->replace_method(); # Calls our replacement method. + + $mock->override(...) # Override some more + + $mock = undef; # Undoes all the mocking, restoring all original methods. + + my $simple_mock = mock {} => ( + add => [ + is_active => sub { ... } + ] + ); + + $simple_mock->is_active(); # Calls our newly mocked method. + +=head1 EXPORTS + +=head2 DEFAULT + +=over 4 + +=item mock + +This is a one-stop shop function that delegates to one of the other methods +depending on how it is used. If you are not comfortable with a function that +has a lot of potential behaviors, you can use one of the other functions +directly. + +=item @mocks = mocked($object) + +=item @mocks = mocked($class) + +Check if an object or class is mocked. If it is mocked the C<$mock> object(s) +(L) will be returned. + +=item $mock = mock $class => ( ... ); + +=item $mock = mock $instance => ( ... ) + +=item $mock = mock 'class', $class => ( ... ) + +These forms delegate to C to mock a package. The third form is to +be explicit about what type of mocking you want. + +=item $obj = mock() + +=item $obj = mock { ... } + +=item $obj = mock 'obj', ...; + +These forms delegate to C to create instances of anonymous packages +where methods are vivified into existence as needed. + +=item mock $mock => sub { ... } + +=item mock $method => ( ... ) + +These forms go together, the first form will set C<$mock> as the current mock +build, then run the sub. Within the sub you can declare mock specifications +using the second form. The first form delegates to C. + +The second form calls the specified method on the current build. This second +form delegates to C. + +=back + +=head2 BY REQUEST + +=head3 DEFINING MOCKS + +=over 4 + +=item $obj = mock_obj( ... ) + +=item $obj = mock_obj { ... } => ( ... ) + +=item $obj = mock_obj sub { ... } + +=item $obj = mock_obj { ... } => sub { ... } + +This method lets you quickly generate a blessed object. The object will be an +instance of a randomly generated package name. Methods will vivify as +read/write accessors as needed. + +Arguments can be any method available to L followed by an +argument. If the very first argument is a hashref then it will be blessed as +your new object. + +If you provide a coderef instead of key/value pairs, the coderef will be run to +build the mock. (See the L section). + +=item $mock = mock_class $class => ( ... ) + +=item $mock = mock_class $instance => ( ... ) + +=item $mock = mock_class ... => sub { ... } + +This will create a new instance of L to control the package +specified. If you give it a blessed reference it will use the class of the +instance. + +Arguments can be any method available to L followed by an +argument. If the very first argument is a hashref then it will be blessed as +your new object. + +If you provide a coderef instead of key/value pairs, the coderef will be run to +build the mock. (See the L section). + +=back + +=head3 BUILDING MOCKS + +=over 4 + +=item mock_build $mock => sub { ... } + +Set C<$mock> as the current build, then run the specified code. C<$mock> will +no longer be the current build when the sub is complete. + +=item $mock = mock_building() + +Get the current building C<$mock> object. + +=item mock_do $method => $args + +Run the specified method on the currently building object. + +=back + +=head3 METHOD GENERATORS + +=over 4 + +=item $sub = mock_accessor $field + +Generate a read/write accessor for the specified field. This will generate a sub like the following: + + $sub = sub { + my $self = shift; + ($self->{$field}) = @_ if @_; + return $self->{$field}; + }; + +=item $sub = mock_getter $field + +Generate a read only accessor for the specified field. This will generate a sub like the following: + + $sub = sub { + my $self = shift; + return $self->{$field}; + }; + +=item $sub = mock_setter $field + +Generate a write accessor for the specified field. This will generate a sub like the following: + + $sub = sub { + my $self = shift; + ($self->{$field}) = @_; + }; + +=item %pairs = mock_accessors(qw/name1 name2 name3/) + +Generates several read/write accessors at once, returns key/value pairs where +the key is the field name, and the value is the coderef. + +=item %pairs = mock_getters(qw/name1 name2 name3/) + +Generates several read only accessors at once, returns key/value pairs where +the key is the field name, and the value is the coderef. + +=item %pairs = mock_setters(qw/name1 name2 name3/) + +Generates several write accessors at once, returns key/value pairs where the +key is the field name, and the value is the coderef. + +=back + +=head1 MOCK CONTROL OBJECTS + + my $mock = mock(...); + +Mock objects are instances of L. See it for their methods. + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +L. + +=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 2018 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 L + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/Tools/Ref.pm b/cpan/Test2-Suite/lib/Test2/Tools/Ref.pm new file mode 100644 index 000000000000..c0457754c833 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Ref.pm @@ -0,0 +1,173 @@ +package Test2::Tools::Ref; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Scalar::Util qw/reftype refaddr/; +use Test2::API qw/context/; +use Test2::Util::Ref qw/render_ref/; + +our @EXPORT = qw/ref_ok ref_is ref_is_not/; +use base 'Exporter'; + +sub ref_ok($;$$) { + my ($thing, $wanttype, $name) = @_; + my $ctx = context(); + + my $gotname = render_ref($thing); + my $gottype = reftype($thing); + + if (!$gottype) { + $ctx->ok(0, $name, ["'$gotname' is not a reference"]); + $ctx->release; + return 0; + } + + if ($wanttype && $gottype ne $wanttype) { + $ctx->ok(0, $name, ["'$gotname' is not a '$wanttype' reference"]); + $ctx->release; + return 0; + } + + $ctx->ok(1, $name); + $ctx->release; + return 1; +} + +sub ref_is($$;$@) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + $got = '' unless defined $got; + $exp = '' unless defined $exp; + + my $bool = 0; + if (!ref($got)) { + $ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]); + } + elsif(!ref($exp)) { + $ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]); + } + else { + # Don't let overloading mess with us. + $bool = refaddr($got) == refaddr($exp); + $ctx->ok($bool, $name, ["'$got' is not the same reference as '$exp'", @diag]); + } + + $ctx->release; + return $bool ? 1 : 0; +} + +sub ref_is_not($$;$) { + my ($got, $exp, $name, @diag) = @_; + my $ctx = context(); + + $got = '' unless defined $got; + $exp = '' unless defined $exp; + + my $bool = 0; + if (!ref($got)) { + $ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]); + } + elsif(!ref($exp)) { + $ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]); + } + else { + # Don't let overloading mess with us. + $bool = refaddr($got) != refaddr($exp); + $ctx->ok($bool, $name, ["'$got' is the same reference as '$exp'", @diag]); + } + + $ctx->release; + return $bool ? 1 : 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Ref - Tools for validating references. + +=head1 DESCRIPTION + +This module contains tools that allow you to verify that something is a ref. It +also has tools to check if two refs are the same exact ref, or different. None of +the functions in this module do deep comparisons. + +=head1 SYNOPSIS + + use Test2::Tools::Ref; + + # Ensure something is a ref. + ref_ok($ref); + + # Check that $ref is a HASH reference + ref_ok($ref, 'HASH', 'Must be a hash') + + ref_is($refa, $refb, "Same exact reference"); + + ref_is_not($refa, $refb, "Not the same exact reference"); + +=head1 EXPORTS + +All subs are exported by default. + +=over 4 + +=item ref_ok($thing) + +=item ref_ok($thing, $type) + +=item ref_ok($thing, $type, $name) + +This checks that C<$thing> is a reference. If C<$type> is specified then it +will check that C<$thing> is that type of reference. + +=item ref_is($ref1, $ref2, $name) + +Verify that two references are the exact same reference. + +=item ref_is_not($ref1, $ref2, $name) + +Verify that two references are not the exact same reference. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Refcount.pm b/cpan/Test2-Suite/lib/Test2/Tools/Refcount.pm new file mode 100644 index 000000000000..4f0dd2883a02 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Refcount.pm @@ -0,0 +1,310 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2008-2023 -- leonerd@leonerd.org.uk + +package Test2::Tools::Refcount; + +use strict; +use warnings; + +use Test2::API qw(context release); + +use Scalar::Util qw( weaken refaddr ); +use B qw( svref_2object ); + +our $VERSION = '0.000156'; + +our @EXPORT = qw( + is_refcount + is_oneref +); + +our @EXPORT_OK = qw( + refcount +); + +use base qw(Exporter); + +use constant HAVE_DEVEL_MAT_DUMPER => defined eval { + package # No Index + Devel::MAT::Dumper; + our $HELPER_PER_PACKAGE; + our $HELPER_PER_MAGIC; + require Devel::MAT::Dumper; +}; + +=encoding UTF-8 + +=head1 NAME + +C - assert reference counts on objects + +=head1 SYNOPSIS + + use Test2::Tools::Refcount; + + use Some::Class; + my $object = Some::Class->new(); + + is_oneref( $object, '$object has a refcount of 1' ); + + my $otherref = $object; + + is_refcount( $object, 2, '$object now has 2 references' ); + +=head1 DESCRIPTION + +The Perl garbage collector uses simple reference counting during the normal +execution of a program. This means that cycles or unweakened references in +other parts of code can keep an object around for longer than intended. To +help avoid this problem, the reference count of a new object from its class +constructor ought to be 1. This way, the caller can know the object will be +properly DESTROYed when it drops all of its references to it. + +This module provides two test functions to help ensure this property holds +for an object class, so as to be polite to its callers. + +If the assertion fails; that is, if the actual reference count is different to +what was expected, either of the following two modules may be used to assist +the developer in finding where the references are. + +=over 4 + +=item * + +If L is installed, this test module will use it to dump the state +of the memory after a failure. It will create a F<.pmat> file named the same +as the unit test, but with the trailing F<.t> suffix replaced with +F<-TEST.pmat> where C is the number of the test that failed (in case +there was more than one). + +=back + +See the examples below for more information. + +=cut + +=head1 FUNCTIONS + +=cut + +=head2 is_refcount + + is_refcount( $object, $count, $name ) + +Test that $object has $count references to it. + +=cut + +sub is_refcount($$;$) +{ + my ( $object, $count, $name ) = @_; + @_ = (); + + my $ctx = context(); + + if( !ref $object ) { + my $ok = $ctx->ok( 0, $name ); + $ctx->diag( " expected a reference, was not given one" ); + $ctx->release; + return $ok; + } + + weaken $object; # So this reference itself doesn't show up + + my $REFCNT = refcount( $object ); + + my $ok = $ctx->ok( $REFCNT == $count, $name ); + + unless( $ok->pass ) { + $ctx->diag( " expected $count references, found $REFCNT" ); + + if( HAVE_DEVEL_MAT_DUMPER ) { + my $file = $0; + my $hub = $ctx->hub; + my $num = $hub->count; + + # Trim the .t off first then append -$num.pmat, in case $0 wasn't a .t file + $file =~ s/\.(?:t|pm|pl)$//; + $file .= "-$num\.pmat"; + $ctx->diag( sprintf "SV address is 0x%x", refaddr $object ); + $ctx->diag( "Writing heap dump to $file" ); + Devel::MAT::Dumper::dump( $file ); + } + } + + $ctx->release; + return $ok; +} + +=head2 is_oneref + + is_oneref( $object, $name ) + +Assert that the $object has only 1 reference to it. + +=cut + +sub is_oneref($;$) +{ + splice( @_, 1, 0, ( 1 ) ); + goto &is_refcount; +} + +=head2 refcount + + $count = refcount( $object ) + +Returns the reference count of the given object as used by the test functions. +This is useful for making tests that don't care what the count is before they +start, but simply assert that the count hasn't changed by the end. + + use Test2::Tools::Refcount import => [qw( is_refcount refcount )]; + { + my $count = refcount( $object ); + + do_something( $object ); + + is_refcount( $object, $count, 'do_something() preserves refcount' ); + } + +=cut + +sub refcount +{ + return svref_2object( $_[0] )->REFCNT; +} + +=head1 EXAMPLE + +Suppose, having written a new class C, you now want to check that its +constructor and methods are well-behaved, and don't leak references. Consider +the following test script: + + use Test::More tests => 2; + use Test2::Tools::Refcount; + + use MyBall; + + my $ball = MyBall->new(); + is_oneref( $ball, 'One reference after construct' ); + + $ball->bounce; + + # Any other code here that might be part of the test script + + is_oneref( $ball, 'One reference just before EOF' ); + +The first assertion is just after the constructor, to check that the reference +returned by it is the only reference to that object. This fact is important if +we ever want C to behave properly. The second call is right at the +end of the file, just before the main scope closes. At this stage we expect +the reference count also to be one, so that the object is properly cleaned up. + +Suppose, when run, this produces the following output (presuming +L is available): + + 1..2 + ok 1 - One reference after construct + not ok 2 - One reference just before EOF + # Failed test 'One reference just before EOF' + # at ex.pl line 26. + # expected 1 references, found 2 + # SV address is 0x55e14c310278 + # Writing heap dump to ex-2.pmat + # Looks like you failed 1 test of 2. + +This has written a F file we can load using the C shell and +use the C command on the given address to find where it went: + + $ pmat ex-2.pmat + Perl memory dumpfile from perl 5.28.1 threaded + Heap contains 25233 objects + pmat> identify 0x55e14c310278 + HASH(0)=MyBall at 0x55e14c310278 is: + ├─(via RV) the lexical $ball at depth 1 of CODE() at 0x55e14c3104a0=main_cv, which is: + │ └─the main code + └─(via RV) value {self} of HASH(2) at 0x55e14cacb860, which is (*A): + └─(via RV) value {cycle} of HASH(2) at 0x55e14cacb860, which is: + itself + +(This document isn't intended to be a full tutorial on L and the +C shell; for that see L). + +From this output, we can see that the constructor was well-behaved, but that a +reference was leaked by the end of the script - the reference count was 2, +when we expected just 1. Reading the trace output, we can see that there were +2 references that could be found - one stored in the $ball lexical in the main +program, and one stored in a HASH. Since we expected to find the $ball lexical +variable, we know we are now looking for a leak in a hash somewhere in the +code. From reading the test script, we can guess this leak is likely to be in +the bounce() method. Furthermore, we know that the reference to the object +will be stored in a HASH in a member called C. + +By reading the code which implements the bounce() method, we can see this is +indeed the case: + + sub bounce + { + my $self = shift; + my $cycle = { self => $self }; + $cycle->{cycle} = $cycle; + } + +From reading the tracing output, we find that the HASH this object is +referenced in also contains a reference to itself, in a member called +C. This comes from the last line in this function, a line that +purposely created a cycle, to demonstrate the point. While a real program +probably wouldn't do anything quite this obvious, the trace would still be +useful in finding the likely cause of the leak. + +If C is not available, then these detailed traces will not +be produced. The basic reference count testing will still take place, but a +smaller message will be produced: + + 1..2 + ok 1 - One reference after construct + not ok 2 - One reference just before EOF + # Failed test 'One reference just before EOF' + # at demo.pl line 16. + # expected 1 references, found 2 + # Looks like you failed 1 test of 2. + +=head1 BUGS + +=over 4 + +=item * Temporaries created on the stack + +Code which creates temporaries on the stack, to be released again when the +called function returns does not work correctly on perl 5.8 (and probably +before). Examples such as + + is_oneref( [] ); + +may fail and claim a reference count of 2 instead. + +Passing a variable such as + + my $array = []; + is_oneref( $array ); + +works fine. Because of the intention of this test module; that is, to assert +reference counts on some object stored in a variable during the lifetime of +the test script, this is unlikely to cause any problems. + +=back + +=head1 ACKNOWLEDGEMENTS + +Peter Rabbitson - for suggesting using core's C +instead of C to obtain refcounts + +=head1 AUTHOR + +Paul Evans + +=cut + +0x55AA; diff --git a/cpan/Test2-Suite/lib/Test2/Tools/Spec.pm b/cpan/Test2-Suite/lib/Test2/Tools/Spec.pm new file mode 100644 index 000000000000..b87368621e8d --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Spec.pm @@ -0,0 +1,676 @@ +package Test2::Tools::Spec; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; +use Test2::Workflow qw/parse_args build current_build root_build init_root build_stack/; + +use Test2::API qw/test2_add_callback_testing_done/; + +use Test2::Workflow::Runner(); +use Test2::Workflow::Task::Action(); +use Test2::Workflow::Task::Group(); +use Test2::Tools::Mock(); +use Test2::Util::Importer(); + +use vars qw/@EXPORT @EXPORT_OK/; +push @EXPORT => qw{describe cases}; +push @EXPORT_OK => qw{include_workflow include_workflows spec_defaults}; + +my %HANDLED; +sub import { + my $class = shift; + my @caller = caller(0); + + my %root_args; + my %runner_args; + my @import; + while (my $arg = shift @_) { + if ($arg =~ s/^-//) { + my $val = shift @_; + + if (Test2::Workflow::Runner->can($arg)) { + $runner_args{$arg} = $val; + } + elsif (Test2::Workflow::Task::Group->can($arg)) { + $root_args{$arg} = $val; + } + elsif ($arg eq 'root_args') { + %root_args = (%root_args, %$val); + } + elsif ($arg eq 'runner_args') { + %runner_args = (%runner_args, %$val); + } + else { + croak "Unrecognized arg: $arg"; + } + } + else { + push @import => $arg; + } + } + + if ($HANDLED{$caller[0]}++) { + croak "Package $caller[0] has already been initialized" + if keys(%root_args) || keys(%runner_args); + } + else { + my $root = init_root( + $caller[0], + frame => \@caller, + code => sub { 1 }, + %root_args, + ); + + my $runner = Test2::Workflow::Runner->new(%runner_args); + + Test2::Tools::Mock->add_handler( + $caller[0], + sub { + my %params = @_; + my ($class, $caller, $builder, $args) = @params{qw/class caller builder args/}; + + my $do_it = eval "package $caller->[0];\n#line $caller->[2] \"$caller->[1]\"\nsub { \$runner\->add_mock(\$builder->()) }"; + + # Running + if (@{$runner->stack}) { + $do_it->(); + } + else { # Not running + my $action = Test2::Workflow::Task::Action->new( + code => $do_it, + name => "mock $class", + frame => $caller, + scaffold => 1, + ); + + my $build = current_build() || $root; + + $build->add_primary_setup($action); + $build->add_stash($builder->()) unless $build->is_root; + } + + return 1; + } + ); + + test2_add_callback_testing_done( + sub { + return unless $root->populated; + my $g = $root->compile; + $runner->push_task($g); + $runner->run; + } + ); + } + + Test2::Util::Importer->import_into($class, $caller[0], @import); +} + +{ + no warnings 'once'; + *cases = \&describe; + *include_workflows = \&include_workflow; +} + +sub describe { + my @caller = caller(0); + + my $want = wantarray; + + my $build = build(args => \@_, caller => \@caller, stack_stop => defined $want ? 1 : 0); + + return $build if defined $want; + + my $current = current_build() || root_build($caller[0]) + or croak "No current workflow build!"; + + $current->add_primary($build); +} + +sub include_workflow { + my @caller = caller(0); + + my $build = current_build() || root_build(\$caller[0]) + or croak "No current workflow build!"; + + for my $task (@_) { + croak "include_workflow only accepts Test2::Workflow::Task objects, got: $task" + unless $task->isa('Test2::Workflow::Task'); + + $build->add_primary($task); + } +} + +sub defaults { + my %params = @_; + + my ($package, $tool) = @params{qw/package tool/}; + + my @stack = (root_build($package), build_stack()); + return unless @stack; + + my %out; + for my $build (@stack) { + %out = () if $build->stack_stop; + my $new = $build->defaults->{$tool} or next; + %out = (%out, %$new); + } + + return \%out; +} + + +# Generate a bunch of subs that only have minor differences between them. +BEGIN { + @EXPORT = qw{ + tests it + case + before_all around_all after_all + before_case around_case after_case + before_each around_each after_each + }; + + @EXPORT_OK = qw{ + mini + iso miso + async masync + }; + + my %stages = ( + case => ['add_variant'], + tests => ['add_primary'], + it => ['add_primary'], + + iso => ['add_primary'], + miso => ['add_primary'], + + async => ['add_primary'], + masync => ['add_primary'], + + mini => ['add_primary'], + + before_all => ['add_setup'], + after_all => ['add_teardown'], + around_all => ['add_setup', 'add_teardown'], + + before_case => ['add_variant_setup'], + after_case => ['add_variant_teardown'], + around_case => ['add_variant_setup', 'add_variant_teardown'], + + before_each => ['add_primary_setup'], + after_each => ['add_primary_teardown'], + around_each => ['add_primary_setup', 'add_primary_teardown'], + ); + + my %props = ( + case => [], + tests => [], + it => [], + + iso => [iso => 1], + miso => [iso => 1, flat => 1], + + async => [async => 1], + masync => [async => 1, flat => 1], + + mini => [flat => 1], + + before_all => [scaffold => 1], + after_all => [scaffold => 1], + around_all => [scaffold => 1, around => 1], + + before_case => [scaffold => 1], + after_case => [scaffold => 1], + around_case => [scaffold => 1, around => 1], + + before_each => [scaffold => 1], + after_each => [scaffold => 1], + around_each => [scaffold => 1, around => 1], + ); + + sub spec_defaults { + my ($tool, %params) = @_; + my @caller = caller(0); + + croak "'$tool' is not a spec tool" + unless exists $props{$tool} || exists $stages{$tool}; + + my $build = current_build() || root_build($caller[0]) + or croak "No current workflow build!"; + + my $old = $build->defaults->{$tool} ||= {}; + $build->defaults->{$tool} = { %$old, %params }; + } + + my $run = ""; + for my $func (@EXPORT, @EXPORT_OK) { + $run .= <<" EOT"; +#line ${ \(__LINE__ + 1) } "${ \__FILE__ }" +sub $func { + my \@caller = caller(0); + my \$args = parse_args(args => \\\@_, caller => \\\@caller); + my \$action = Test2::Workflow::Task::Action->new(\@{\$props{$func}}, %\$args); + + return \$action if defined wantarray; + + my \$build = current_build() || root_build(\$caller[0]) + or croak "No current workflow build!"; + + if (my \$defaults = defaults(package => \$caller[0], tool => '$func')) { + for my \$attr (keys \%\$defaults) { + next if defined \$action->\$attr; + my \$sub = "set_\$attr"; + \$action->\$sub(\$defaults->{\$attr}); + } + } + + \$build->\$_(\$action) for \@{\$stages{$func}}; +} + EOT + } + + my ($ok, $err); + { + local $@; + $ok = eval "$run\n1"; + $err = $@; + } + + die $@ unless $ok; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Spec - RSPEC implementation on top of Test2::Workflow + +=head1 DESCRIPTION + +This uses L to implement an RSPEC variant. This variant +supports isolation and/or concurrency via forking or threads. + +=head1 SYNOPSIS + + use Test2::Bundle::Extended; + use Test2::Tools::Spec; + + describe foo => sub { + before_all once => sub { ... }; + before_each many => sub { ... }; + + after_all once => sub { ... }; + after_each many => sub { ... }; + + case condition_a => sub { ... }; + case condition_b => sub { ... }; + + tests foo => sub { ... }; + tests bar => sub { ... }; + }; + + done_testing; + +=head1 EXPORTS + +All of these use the same argument pattern. The first argument must always be a +name for the block. The last argument must always be a code reference. +Optionally a configuration hash can be inserted between the name and the code +reference. + + FUNCTION "name" => sub { ... }; + + FUNCTION "name" => {...}, sub { ... }; + +=over 4 + +=item NAME + +The first argument to a Test2::Tools::Spec function MUST be a name. The name +does not need to be unique. + +=item PARAMS + +This argument is optional. If present this should be a hashref. + +Here are the valid keys for the hashref: + +=over 8 + +=item flat => $bool + +If this is set to true then the block will not render as a subtest, instead the +events will be inline with the parent subtest (or main test). + +=item async => $bool + +Set this to true to mark a block as being capable of running concurrently with +other test blocks. This does not mean the block WILL be run concurrently, just +that it can be. + +=item iso => $bool + +Set this to true if the block MUST be run in isolation. If this is true then +the block will run in its own forked process. + +These tests will be skipped on any platform that does not have true forking, or +working/enabled threads. + +Threads will ONLY be used if the T2_WORKFLOW_USE_THREADS env var is set. Thread +tests are only run if the T2_DO_THREAD_TESTS env var is set. + +=item todo => $reason + +Use this to mark an entire block as TODO. + +=item skip => $reason + +Use this to prevent a block from running at all. + +=back + +=item CODEREF + +This argument is required. This should be a code reference that will run some +assertions. + +=back + +=head2 ESSENTIALS + +=over 4 + +=item tests NAME => sub { ... } + +=item tests NAME => \%params, sub { ... } + +=item tests($NAME, \%PARAMS, \&CODE) + +=item it NAME => sub { ... } + +=item it NAME => \%params, sub { ... } + +=item it($NAME, \%PARAMS, \&CODE) + +This defines a test block. Test blocks are essentially subtests. All test +blocks will be run, and are expected to produce events. Test blocks can run +multiple times if the C function is also used. + +C is an alias to C. + +These ARE NOT inherited by nested describe blocks. + +=item case NAME => sub { ... } + +=item case NAME => \%params, sub { ... } + +=item case($NAME, \%PARAMS, \&CODE) + +This lets you specify multiple conditions in which the test blocks should be +run. Every test block within the same group (C) will be run once per +case. + +These ARE NOT inherited by nested describe blocks, but nested describe blocks +will be executed once per case. + +=item before_each NAME => sub { ... } + +=item before_each NAME => \%params, sub { ... } + +=item before_each($NAME, \%PARAMS, \&CODE) + +Specify a codeblock that should be run multiple times, once before each +C block is run. These will run AFTER C blocks but before +C blocks. + +These ARE inherited by nested describe blocks. + +=item before_case NAME => sub { ... } + +=item before_case NAME => \%params, sub { ... } + +=item before_case($NAME, \%PARAMS, \&CODE) + +Same as C, except these blocks run BEFORE C blocks. + +These ARE NOT inherited by nested describe blocks. + +=item before_all NAME => sub { ... } + +=item before_all NAME => \%params, sub { ... } + +=item before_all($NAME, \%PARAMS, \&CODE) + +Specify a codeblock that should be run once, before all the test blocks run. + +These ARE NOT inherited by nested describe blocks. + +=item around_each NAME => sub { ... } + +=item around_each NAME => \%params, sub { ... } + +=item around_each($NAME, \%PARAMS, \&CODE) + +Specify a codeblock that should wrap around each test block. These blocks are +run AFTER case blocks, but before test blocks. + + around_each wrapit => sub { + my $cont = shift; + + local %ENV = ( ... ); + + $cont->(); + + ... + }; + +The first argument to the codeblock will be a callback that MUST be called +somewhere inside the sub in order for nested items to run. + +These ARE inherited by nested describe blocks. + +=item around_case NAME => sub { ... } + +=item around_case NAME => \%params, sub { ... } + +=item around_case($NAME, \%PARAMS, \&CODE) + +Same as C except these run BEFORE case blocks. + +These ARE NOT inherited by nested describe blocks. + +=item around_all NAME => sub { ... } + +=item around_all NAME => \%params, sub { ... } + +=item around_all($NAME, \%PARAMS, \&CODE) + +Same as C except that it only runs once to wrap ALL test blocks. + +These ARE NOT inherited by nested describe blocks. + +=item after_each NAME => sub { ... } + +=item after_each NAME => \%params, sub { ... } + +=item after_each($NAME, \%PARAMS, \&CODE) + +Same as C except it runs right after each test block. + +These ARE inherited by nested describe blocks. + +=item after_case NAME => sub { ... } + +=item after_case NAME => \%params, sub { ... } + +=item after_case($NAME, \%PARAMS, \&CODE) + +Same as C except it runs right after the case block, and before the +test block. + +These ARE NOT inherited by nested describe blocks. + +=item after_all NAME => sub { ... } + +=item after_all NAME => \%params, sub { ... } + +=item after_all($NAME, \%PARAMS, \&CODE) + +Same as C except it runs after all test blocks have been run. + +These ARE NOT inherited by nested describe blocks. + +=back + +=head2 SHORTCUTS + +These are shortcuts. Each of these is the same as C except some +parameters are added for you. + +These are NOT exported by default/. + +=over 4 + +=item mini NAME => sub { ... } + +Same as: + + tests NAME => { flat => 1 }, sub { ... } + +=item iso NAME => sub { ... } + +Same as: + + tests NAME => { iso => 1 }, sub { ... } + +=item miso NAME => sub { ... } + +Same as: + + tests NAME => { mini => 1, iso => 1 }, sub { ... } + +=item async NAME => sub { ... } + +Same as: + + tests NAME => { async => 1 }, sub { ... } + +B This conflicts with the C exported from L. Don't +import both. + +=item masync NAME => sub { ... } + +Same as: + + tests NAME => { minit => 1, async => 1 }, sub { ... } + +=back + +=head2 CUSTOM ATTRIBUTE DEFAULTS + +Sometimes you want to apply default attributes to all C or C +blocks. This can be done, and is lexical to your describe or package root! + + use Test2::Bundle::Extended; + use Test2::Tools::Spec ':ALL'; + + # All 'tests' blocks after this declaration will have C< 1>> by default + spec_defaults tests => (iso => 1); + + tests foo => sub { ... }; # isolated + + tests foo, {iso => 0}, sub { ... }; # Not isolated + + spec_defaults tests => (iso => 0); # Turn it off again + +Defaults are inherited by nested describe blocks. You can also override the +defaults for the scope of the describe: + + spec_defaults tests => (iso => 1); + + describe foo => sub { + spec_defaults tests => (async => 1); # Scoped to this describe and any child describes + + tests bar => sub { ... }; # both iso and async + }; + + tests baz => sub { ... }; # Just iso, no async. + +You can apply defaults to any type of blocks: + + spec_defaults case => (iso => 1); # All cases are 'iso'; + +Defaults are not inherited when a builder's return is captured. + + spec_defaults tests => (iso => 1); + + # Note we are not calling this in void context, that is the key here. + my $d = describe foo => { + tests bar => sub { ... }; # Not iso + }; + +=head1 EXECUTION ORDER + +As each function is encountered it executes, just like any other function. The +C function will immediately execute the codeblock it is given. All +other functions will stash their codeblocks to be run later. When +C is run the workflow will be compiled, at which point all +other blocks will run. + +Here is an overview of the order in which blocks get called once compiled (at +C). + + before_all + for-each-case { + before_case + case + after_case + + # AND/OR nested describes + before_each + tests + after_each + } + after_all + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/lib/Test2/Tools/Subtest.pm b/cpan/Test2-Suite/lib/Test2/Tools/Subtest.pm new file mode 100644 index 000000000000..5353418b9259 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Subtest.pm @@ -0,0 +1,172 @@ +package Test2::Tools::Subtest; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API qw/context run_subtest/; +use Test2::Util qw/try/; + +our @EXPORT = qw/subtest_streamed subtest_buffered/; +use base 'Exporter'; + +sub subtest_streamed { + my $name = shift; + my $params = ref($_[0]) eq 'HASH' ? shift(@_) : {}; + my $code = shift; + + $params->{buffered} = 0 unless defined $params->{buffered}; + + my $ctx = context(); + my $pass = run_subtest("Subtest: $name", $code, $params, @_); + $ctx->release; + return $pass; +} + +sub subtest_buffered { + my $name = shift; + my $params = ref($_[0]) eq 'HASH' ? shift(@_) : {}; + my $code = shift; + + $params->{buffered} = 1 unless defined $params->{buffered}; + + my $ctx = context(); + my $pass = run_subtest($name, $code, $params, @_); + $ctx->release; + return $pass; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Subtest - Tools for writing subtests + +=head1 DESCRIPTION + +This package exports subs that let you write subtests. + +There are two types of subtests, buffered and streamed. Streamed subtests mimic +subtests from L in that they render all events as soon as they are +produced. Buffered subtests wait until the subtest completes before rendering +any results. + +The main difference is that streamed subtests are unreadable when combined with +concurrency. Buffered subtests look fine with any number of concurrent threads +and processes. + +=head1 SYNOPSIS + +=head2 BUFFERED + + use Test2::Tools::Subtest qw/subtest_buffered/; + + subtest_buffered my_test => sub { + ok(1, "subtest event A"); + ok(1, "subtest event B"); + }; + +This will produce output like this: + + ok 1 - my_test { + ok 1 - subtest event A + ok 2 - subtest event B + 1..2 + } + +=head2 STREAMED + +The default option is 'buffered'. If you want streamed subtests, +the way L does it, use this: + + use Test2::Tools::Subtest qw/subtest_streamed/; + + subtest_streamed my_test => sub { + ok(1, "subtest event A"); + ok(1, "subtest event B"); + }; + +This will produce output like this: + + # Subtest: my_test + ok 1 - subtest event A + ok 2 - subtest event B + 1..2 + ok 1 - Subtest: my_test + +=head1 IMPORTANT NOTE + +You can use C or C in a subtest, but not in a BEGIN block +or C statement. This is due to the way flow control works within a BEGIN +block. This is not normally an issue, but can happen in rare conditions using +eval, or script files as subtests. + +=head1 EXPORTS + +=over 4 + +=item subtest_streamed $name => $sub + +=item subtest_streamed($name, $sub, @args) + +=item subtest_streamed $name => \%params, $sub + +=item subtest_streamed($name, \%params, $sub, @args) + +Run subtest coderef, stream events as they happen. + +C<\%params> is a hashref with any arguments you wish to pass into hub +construction. + +=item subtest_buffered $name => $sub + +=item subtest_buffered($name, $sub, @args) + +=item subtest_buffered $name => \%params, $sub + +=item subtest_buffered($name, \%params, $sub, @args) + +Run subtest coderef, render events all at once when subtest is complete. + +C<\%params> is a hashref with any arguments you wish to pass into hub +construction. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Target.pm b/cpan/Test2-Suite/lib/Test2/Tools/Target.pm new file mode 100644 index 000000000000..31e6d9bc37a8 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Target.pm @@ -0,0 +1,118 @@ +package Test2::Tools::Target; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; + +use Test2::Util qw/pkg_to_file/; + +sub import { + my $class = shift; + + my $caller = caller; + $class->import_into($caller, @_); +} + +sub import_into { + my $class = shift; + my $into = shift or croak "no destination package provided"; + + croak "No targets specified" unless @_; + + my %targets; + if (@_ == 1) { + if (ref $_[0] eq 'HASH') { + %targets = %{ $_[0] }; + } + else { + ($targets{CLASS}) = @_; + } + } + else { + %targets = @_; + } + + for my $name (keys %targets) { + my $target = $targets{$name}; + + my $file = pkg_to_file($target); + require $file; + + $name ||= 'CLASS'; + + my $const; + { + my $const_target = "$target"; + $const = sub() { $const_target }; + } + + no strict 'refs'; + *{"$into\::$name"} = \$target; + *{"$into\::$name"} = $const; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Target - Alias the testing target package. + +=head1 DESCRIPTION + +This lets you alias the package you are testing into a constant and a package +variable. + +=head1 SYNOPSIS + + use Test2::Tools::Target 'Some::Package'; + + CLASS()->xxx; # Call 'xxx' on Some::Package + $CLASS->xxx; # Same + +Or you can specify names: + + use Test2::Tools::Target pkg => 'Some::Package'; + + pkg()->xxx; # Call 'xxx' on Some::Package + $pkg->xxx; # Same + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Tester.pm b/cpan/Test2-Suite/lib/Test2/Tools/Tester.pm new file mode 100644 index 000000000000..fa2d0b53b9c6 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Tester.pm @@ -0,0 +1,295 @@ +package Test2::Tools::Tester; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; +use Test2::Util::Ref qw/rtype/; + +BEGIN { + if (eval { require Module::Pluggable; 1 }) { + Module::Pluggable->import(search_path => ['Test2::EventFacet'], require => 1); + } + else { + require Test2::EventFacet::About; + require Test2::EventFacet::Amnesty; + require Test2::EventFacet::Assert; + require Test2::EventFacet::Control; + require Test2::EventFacet::Error; + require Test2::EventFacet::Hub; + require Test2::EventFacet::Info; + require Test2::EventFacet::Info::Table; + require Test2::EventFacet::Meta; + require Test2::EventFacet::Parent; + require Test2::EventFacet::Plan; + require Test2::EventFacet::Render; + require Test2::EventFacet::Trace; + + *plugins = sub { + return ( + 'Test2::EventFacet::About', + 'Test2::EventFacet::Amnesty', + 'Test2::EventFacet::Assert', + 'Test2::EventFacet::Control', + 'Test2::EventFacet::Error', + 'Test2::EventFacet::Hub', + 'Test2::EventFacet::Info', + 'Test2::EventFacet::Info::Table', + 'Test2::EventFacet::Meta', + 'Test2::EventFacet::Parent', + 'Test2::EventFacet::Plan', + 'Test2::EventFacet::Render', + 'Test2::EventFacet::Trace', + ); + }; + } +} + +use Test2::Util::Importer 'Test2::Util::Importer' => 'import'; + +our @EXPORT_OK = qw{ + facets + filter_events + event_groups +}; + +my %TYPES; +for my $class (__PACKAGE__->plugins) { + my $type = $class; + $type =~ s/^Test2::EventFacet:://g; + + next unless $class->isa('Test2::EventFacet'); + my $key; + $key = $class->facet_key if $class->can('facet_key'); + $key = lc($type) unless defined $key; + + $TYPES{$type} = $class; + $TYPES{lc($type)} = $class; + $TYPES{$key} = $class; +} + +sub filter_events { + my $events = shift; + + my @match = map { rtype($_) eq 'REGEXP' ? $_ : qr/^\Q$_\E::/} @_; + + my @out; + for my $e (@$events) { + my $trace = $e->facet_data->{trace} or next; + next unless grep { $trace->{frame}->[3] =~ $_ } @match; + push @out => $e; + } + + return \@out; +} + +sub event_groups { + my $events = shift; + + my $out = {}; + for my $e (@$events) { + my $trace = $e->facet_data->{trace}; + my $tool = ($trace && $trace->{frame} && $trace->{frame}->[3]) ? $trace->{frame}->[3] : undef; + + unless ($tool) { + push @{$out->{__NA__}} => $e; + next; + } + + my ($pkg, $sub) = ($tool =~ m/^(.*)(?:::|')([^:']+)$/); + + push @{$out->{$pkg}->{$sub}} => $e; + push @{$out->{$pkg}->{__ALL__}} => $e; + } + + return $out; +} + +sub facets { + my ($type, $events) = @_; + + my ($key, $is_list); + my $class = $TYPES{$type}; + if ($class) { + $key = $class->facet_key || lc($type); + $is_list = $class->is_list; + } + else { + $key = lc($type); + } + + my @out; + for my $e (@$events) { + my $fd = $e->facet_data; + my $f = $fd->{$key} or next; + + my $list = defined($is_list) ? $is_list : rtype($f) eq 'ARRAY'; + + if ($list) { + push @out => map { $class ? $class->new($_) : $_ } @$f; + } + else { + push @out => $class ? $class->new($f) : $f; + } + } + + return \@out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Tester - Tools to help you test other testing tools. + +=head1 DESCRIPTION + +This is a collection of tools that are useful when testing other test tools. + +=head1 SYNOPSIS + + use Test2::Tools::Tester qw/event_groups filter_events facets/; + + use Test2::Tools::Basic qw/plan pass ok/; + use Test2::Tools::Compare qw/is like/; + + my $events = intercept { + plan 11; + + pass('pass'); + ok(1, 'pass'); + + is(1, 1, "pass"); + like(1, 1, "pass"); + }; + + # Grab events generated by tools in Test2::Tools::Basic + my $basic = filter $events => 'Test2::Tools::Basic'; + + # Grab events generated by Test2::Tools::Basic; + my $compare = filter $events => 'Test2::Tools::Compare'; + + # Grab events generated by tools named 'ok'. + my $oks = filter $events => qr/.*::ok$/; + + my $grouped = group_events $events; + # Breaks events into this structure: + { + '__NA__' => [ ... ], + 'Test2::Tools::Basic' => { + '__ALL__' => [ $events->[0], $events->[1], $events->[2] ], + plan => [ $events->[0] ], + pass => [ $events->[1] ], + ok => [ $events->[2] ], + }, + Test2::Tools::Compare => { ... }, + } + + # Get an arrayref of all the assert facets from the list of events. + my $assert_facets = facets assert => $events; + # [ + # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), + # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), + # ] + + # Same, but for info facets + my $info_facets = facets info => $events; + +=head1 EXPORTS + +No subs are exported by default. + +=over 4 + +=item $array_ref = filter $events => $PACKAGE + +=item $array_ref = filter $events => $PACKAGE1, $PACKAGE2 + +=item $array_ref = filter $events => qr/match/ + +=item $array_ref = filter $events => qr/match/, $PACKAGE + +This function takes an arrayref of events as the first argument. All additional +arguments must either be a package name, or a regex. Any event that is +generated by a tool in any of the package, or by a tool that matches any of the +regexes, will be returned in an arrayref. + +=item $grouped = group_events($events) + +This function iterates all the events in the argument arrayref and splits them +into groups. The resulting data structure is: + + { PACKAGE => { SUBNAME => [ $EVENT1, $EVENT2, ... }} + +If the package of an event is not known it will be put into and arrayref under +the '__NA__' key at the root of the structure. If a sub name is not known it +will typically go under the '__ANON__' key in under the package name. + +In addition there is an '__ALL__' key under each package which stores all of +the events sorted into that group. + +A more complete example: + + { + '__NA__' => [ $event->[3] ], + 'Test2::Tools::Basic' => { + '__ALL__' => [ $events->[0], $events->[1], $events->[2] ], + plan => [ $events->[0] ], + pass => [ $events->[1] ], + ok => [ $events->[2] ], + }, + } + +=item $arrayref = facets TYPE => $events + +This function will compile a list of all facets of the specified type that are +found in the arrayref of events. If the facet has a C +package available then the facet will be constructed into an instance of the +class, otherwise it is left as a hashref. Facet Order is preserved. + + my $assert_facets = facets assert => $events; + # [ + # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), + # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), + # ] + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Tools/Warnings.pm b/cpan/Test2-Suite/lib/Test2/Tools/Warnings.pm new file mode 100644 index 000000000000..ed3ee957808c --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Tools/Warnings.pm @@ -0,0 +1,153 @@ +package Test2::Tools::Warnings; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API qw/context/; + +our @EXPORT = qw/warns warning warnings no_warnings/; +use base 'Exporter'; + +sub warns(&) { + my $code = shift; + my $warnings = 0; + local $SIG{__WARN__} = sub { $warnings++ }; + $code->(); + return $warnings; +} + +sub no_warnings(&) { return !&warns(@_) } + +sub warning(&) { + my $code = shift; + my @warnings; + { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $code->(); + return unless @warnings; + } + + if (@warnings > 1) { + my $ctx = context(); + $ctx->alert("Extra warnings in warning { ... }"); + $ctx->note($_) for @warnings; + $ctx->release; + } + + return $warnings[0]; +} + +sub warnings(&) { + my $code = shift; + + my @warnings; + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $code->(); + + return \@warnings; +} + +1; + + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Warnings - Tools to verify warnings. + +=head1 DESCRIPTION + +This is a collection of tools that can be used to test code that issues +warnings. + +=head1 SYNOPSIS + + use Test2::Tools::Warnings qw/warns warning warnings no_warnings/; + + ok(warns { warn 'a' }, "the code warns"); + ok(!warns { 1 }, "The code does not warn"); + is(warns { warn 'a'; warn 'b' }, 2, "got 2 warnings"); + + ok(no_warnings { ... }, "code did not warn"); + + like( + warning { warn 'xxx' }, + qr/xxx/, + "Got expected warning" + ); + + is( + warnings { warn "a\n"; warn "b\n" }, + [ + "a\n", + "b\n", + ], + "Got 2 specific warnings" + ); + +=head1 EXPORTS + +All subs are exported by default. + +=over 4 + +=item $count = warns { ... } + +Returns the count of warnings produced by the block. This will always return 0, +or a positive integer. + +=item $warning = warning { ... } + +Returns the first warning generated by the block. If the block produces more +than one warning, they will all be shown as notes, and an actual warning will tell +you about it. + +=item $warnings_ref = warnings { ... } + +Returns an arrayref with all the warnings produced by the block. This will +always return an array reference. If there are no warnings, this will return an +empty array reference. + +=item $bool = no_warnings { ... } + +Return true if the block has no warnings. Returns false if there are warnings. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Util/Grabber.pm b/cpan/Test2-Suite/lib/Test2/Util/Grabber.pm new file mode 100644 index 000000000000..385c668d3165 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Grabber.pm @@ -0,0 +1,251 @@ +package Test2::Util::Grabber; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Hub::Interceptor(); +use Test2::EventFacet::Trace(); + +use Test2::API qw/test2_stack test2_ipc/; + +use Test2::Util::HashBase qw/hub finished _events term_size top(); + + my $hub = test2_stack->new_hub( + class => 'Test2::Hub::Interceptor', + formatter => undef, + no_ending => 1, + ); + + $self->{+HUB} = $hub; + + my @events; + $hub->listen(sub { push @events => $_[1] }); + + $self->{+_EVENTS} = \@events; + + $self->{+TERM_SIZE} = $ENV{TS_TERM_SIZE}; + $ENV{TS_TERM_SIZE} = 80; + + my $trace = $self->{+TRACE} ||= Test2::EventFacet::Trace->new(frame => [caller(1)]); + my $state = $self->{+STATE} ||= {}; + $hub->clean_inherited(trace => $trace, state => $state); + + return; +} + +sub flush { + my $self = shift; + my $out = [@{$self->{+_EVENTS}}]; + @{$self->{+_EVENTS}} = (); + return $out; +} + +sub events { + my $self = shift; + # Copy + return [@{$self->{+_EVENTS}}]; +} + +sub finish { + my ($self) = @_; # Do not shift; + $_[0] = undef; + + if (defined $self->{+TERM_SIZE}) { + $ENV{TS_TERM_SIZE} = $self->{+TERM_SIZE}; + } + else { + delete $ENV{TS_TERM_SIZE}; + } + + my $hub = $self->{+HUB}; + + $self->{+FINISHED} = 1; + test2_stack()->pop($hub); + + my $trace = $self->{+TRACE} ||= Test2::EventFacet::Trace->new(frame => [caller(1)]); + my $state = $self->{+STATE} ||= {}; + $hub->clean_inherited(trace => $trace, state => $state); + + my $dbg = Test2::EventFacet::Trace->new( + frame => [caller(0)], + ); + $hub->finalize($dbg, 1) + if !$hub->no_ending + && !$hub->state->ended; + + return $self->flush; +} + +sub DESTROY { + my $self = shift; + return if $self->{+FINISHED}; + test2_stack->pop($self->{+HUB}); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Grabber - Object used to temporarily intercept all events. + +=head1 DESCRIPTION + +Once created this object will intercept and stash all events sent to the shared +L object. Once the object is destroyed, events will once +again be sent to the shared hub. + +=head1 SYNOPSIS + + use Test2 qw/Core Grab/; + + my $grab = grab(); + + # Generate some events, they are intercepted. + ok(1, "pass"); + ok(0, "fail"); + + my $events_a = $grab->flush; + + # Generate some more events, they are intercepted. + ok(1, "pass"); + ok(0, "fail"); + + # Same as flush, except it destroys the grab object. + my $events_b = $grab->finish; + +After calling C the grab object is destroyed and C<$grab> is set to +undef. C<$events_a> is an arrayref with the first two events. C<$events_b> is an +arrayref with the second two events. + +=head1 EXPORTS + +=over 4 + +=item $grab = grab() + +This lets you intercept all events for a section of code without adding +anything to your call stack. This is useful for things that are sensitive to +changes in the stack depth. + + my $grab = grab(); + ok(1, 'foo'); + ok(0, 'bar'); + + # $grab is magically undef after this. + my $events = $grab->finish; + + is(@$events, 2, "grabbed two events."); + +When you call C the C<$grab> object will automagically undef itself, +but only for the reference used in the method call. If you have other +references to the C<$grab> object they will not be set to undef. + +If the C<$grab> object is destroyed without calling C, it will +automatically clean up after itself and restore the parent hub. + + { + my $grab = grab(); + # Things are grabbed + } + # Things are back to normal + +By default the hub used has C set to true. This will prevent the hub +from enforcing that you issued a plan and ran at least one test. You can turn +enforcement back one like this: + + $grab->hub->set_no_ending(0); + +With C turned off, C will run the post-test checks to +enforce the plan and that tests were run. In many cases this will result in +additional events in your events array. + +=back + +=head1 METHODS + +=over 4 + +=item $grab = $class->new() + +Create a new grab object, immediately starts intercepting events. + +=item $ar = $grab->flush() + +Get an arrayref of all the events so far, clearing the grab objects internal +list. + +=item $ar = $grab->events() + +Get an arrayref of all events so far. Does not clear the internal list. + +=item $ar = $grab->finish() + +Get an arrayref of all the events, then destroy the grab object. + +=item $hub = $grab->hub() + +Get the hub that is used by the grab event. + +=back + +=head1 ENDING BEHAVIOR + +By default the hub used has C set to true. This will prevent the hub +from enforcing that you issued a plan and ran at least one test. You can turn +enforcement back one like this: + + $grab->hub->set_no_ending(0); + +With C turned off, C will run the post-test checks to +enforce the plan and that tests were run. In many cases this will result in +additional events in your events array. + +=head1 SEE ALSO + +L - Accomplish the same thing, but using +blocks instead. + +=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 2018 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/cpan/Test2-Suite/lib/Test2/Util/Guard.pm b/cpan/Test2-Suite/lib/Test2/Util/Guard.pm new file mode 100644 index 000000000000..1d5252556799 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Guard.pm @@ -0,0 +1,76 @@ +package Test2::Util::Guard; + +use strict; +use warnings; + +use Carp qw(confess); + +our $VERSION = '0.000156'; + +sub new { + confess "Can't create a Test2::Util::Guard in void context" unless (defined wantarray); + + my $class = shift; + my $handler = shift() || die 'Test2::Util::Guard::new: no handler supplied'; + my $ref = ref $handler || ''; + + die "Test2::Util::new: invalid handler - expected CODE ref, got: '$ref'" + unless ref($handler) eq 'CODE'; + + bless [ 0, $handler ], ref $class || $class; +} + +sub dismiss { + my $self = shift; + my $dismiss = @_ ? shift : 1; + + $self->[0] = $dismiss; +} + +sub DESTROY { + my $self = shift; + my ($dismiss, $handler) = @$self; + + $handler->() unless ($dismiss); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Test2::Util::Guard - Inline copy of L + +=head1 SEE ALSO + +See L + +=head1 ORIGINAL AUTHOR + +=over 4 + +=item chocolateboy + +=back + +=head2 INLINE AND MODIFICATION AUTHOR + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright (c) 2005-2015, chocolateboy. + +Modified copy is Copyright 2023 Chad Granum Eexodist7@gmail.comE. + +This module is free software. It may be used, redistributed and/or modified under the same terms +as Perl itself. + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/Util/Importer.pm b/cpan/Test2-Suite/lib/Test2/Util/Importer.pm new file mode 100644 index 000000000000..27f01218635a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Importer.pm @@ -0,0 +1,812 @@ +package Test2::Util::Importer; +use strict; no strict 'refs'; +use warnings; no warnings 'once'; + +our $VERSION = '0.000156'; + +my %SIG_TO_SLOT = ( + '&' => 'CODE', + '$' => 'SCALAR', + '%' => 'HASH', + '@' => 'ARRAY', + '*' => 'GLOB', +); + +our %IMPORTED; + +# This will be used to check if an import arg is a version number +my %NUMERIC = map +($_ => 1), 0 .. 9; + +sub IMPORTER_MENU() { + return ( + export_ok => [qw/optimal_import/], + export_anon => { + import => sub { + my $from = shift; + my @caller = caller(0); + + _version_check($from, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)}; + + my $file = _mod_to_file($from); + _load_file(\@caller, $file) unless $INC{$file}; + + return if optimal_import($from, $caller[0], \@caller, @_); + + my $self = __PACKAGE__->new( + from => $from, + caller => \@caller, + ); + + $self->do_import($caller[0], @_); + }, + }, + ); +} + +########################################################################### +# +# These are class methods +# import and unimport are what you would expect. +# import_into and unimport_from are the indirect forms you can use in other +# package import() methods. +# +# These all attempt to do a fast optimal-import if possible, then fallback to +# the full-featured import that constructs an object when needed. +# + +sub import { + my $class = shift; + + my @caller = caller(0); + + _version_check($class, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)}; + + return unless @_; + + my ($from, @args) = @_; + + my $file = _mod_to_file($from); + _load_file(\@caller, $file) unless $INC{$file}; + + return if optimal_import($from, $caller[0], \@caller, @args); + + my $self = $class->new( + from => $from, + caller => \@caller, + ); + + $self->do_import($caller[0], @args); +} + +sub unimport { + my $class = shift; + my @caller = caller(0); + + my $self = $class->new( + from => $caller[0], + caller => \@caller, + ); + + $self->do_unimport(@_); +} + +sub import_into { + my $class = shift; + my ($from, $into, @args) = @_; + + my @caller; + + if (ref($into)) { + @caller = @$into; + $into = $caller[0]; + } + elsif ($into =~ m/^\d+$/) { + @caller = caller($into + 1); + $into = $caller[0]; + } + else { + @caller = caller(0); + } + + my $file = _mod_to_file($from); + _load_file(\@caller, $file) unless $INC{$file}; + + return if optimal_import($from, $into, \@caller, @args); + + my $self = $class->new( + from => $from, + caller => \@caller, + ); + + $self->do_import($into, @args); +} + +sub unimport_from { + my $class = shift; + my ($from, @args) = @_; + + my @caller; + if ($from =~ m/^\d+$/) { + @caller = caller($from + 1); + $from = $caller[0]; + } + else { + @caller = caller(0); + } + + my $self = $class->new( + from => $from, + caller => \@caller, + ); + + $self->do_unimport(@args); +} + +########################################################################### +# +# Constructors +# + +sub new { + my $class = shift; + my %params = @_; + + my $caller = $params{caller} || [caller()]; + + die "You must specify a package to import from at $caller->[1] line $caller->[2].\n" + unless $params{from}; + + return bless { + from => $params{from}, + caller => $params{caller}, # Do not use our caller. + }, $class; +} + +########################################################################### +# +# Shortcuts for getting symbols without any namespace modifications +# + +sub get { + my $proto = shift; + my @caller = caller(1); + + my $self = ref($proto) ? $proto : $proto->new( + from => shift(@_), + caller => \@caller, + ); + + my %result; + $self->do_import($caller[0], @_, sub { $result{$_[0]} = $_[1] }); + return \%result; +} + +sub get_list { + my $proto = shift; + my @caller = caller(1); + + my $self = ref($proto) ? $proto : $proto->new( + from => shift(@_), + caller => \@caller, + ); + + my @result; + $self->do_import($caller[0], @_, sub { push @result => $_[1] }); + return @result; +} + +sub get_one { + my $proto = shift; + my @caller = caller(1); + + my $self = ref($proto) ? $proto : $proto->new( + from => shift(@_), + caller => \@caller, + ); + + my $result; + $self->do_import($caller[0], @_, sub { $result = $_[1] }); + return $result; +} + +########################################################################### +# +# Object methods +# + +sub do_import { + my $self = shift; + + my ($into, $versions, $exclude, $import, $set) = $self->parse_args(@_); + + # Exporter supported multiple version numbers being listed... + _version_check($self->from, $self->get_caller, @$versions) if @$versions; + + return unless @$import; + + $self->_handle_fail($into, $import) if $self->menu($into)->{fail}; + $self->_set_symbols($into, $exclude, $import, $set); +} + +sub do_unimport { + my $self = shift; + + my $from = $self->from; + my $imported = $IMPORTED{$from} or $self->croak("'$from' does not have any imports to remove"); + + my %allowed = map { $_ => 1 } @$imported; + + my @args = @_ ? @_ : @$imported; + + my $stash = \%{"$from\::"}; + + for my $name (@args) { + $name =~ s/^&//; + + $self->croak("Sub '$name' was not imported using " . ref($self)) unless $allowed{$name}; + + my $glob = delete $stash->{$name}; + local *GLOBCLONE = *$glob; + + for my $type (qw/SCALAR HASH ARRAY FORMAT IO/) { + next unless defined(*{$glob}{$type}); + *{"$from\::$name"} = *{$glob}{$type} + } + } +} + +sub from { $_[0]->{from} } + +sub from_file { + my $self = shift; + + $self->{from_file} ||= _mod_to_file($self->{from}); + + return $self->{from_file}; +} + +sub load_from { + my $self = shift; + my $from_file = $self->from_file; + my $this_file = __FILE__; + + return if $INC{$from_file}; + + my $caller = $self->get_caller; + + _load_file($caller, $from_file); +} + +sub get_caller { + my $self = shift; + return $self->{caller} if $self->{caller}; + + my $level = 1; + while(my @caller = caller($level++)) { + return \@caller if @caller && !$caller[0]->isa(__PACKAGE__); + last unless @caller; + } + + # Fallback + return [caller(0)]; +} + +sub croak { + my $self = shift; + my ($msg) = @_; + my $caller = $self->get_caller; + my $file = $caller->[1] || 'unknown file'; + my $line = $caller->[2] || 'unknown line'; + die "$msg at $file line $line.\n"; +} + +sub carp { + my $self = shift; + my ($msg) = @_; + my $caller = $self->get_caller; + my $file = $caller->[1] || 'unknown file'; + my $line = $caller->[2] || 'unknown line'; + warn "$msg at $file line $line.\n"; +} + +sub menu { + my $self = shift; + my ($into) = @_; + + $self->croak("menu() requires the name of the destination package") + unless $into; + + my $for = $self->{menu_for}; + delete $self->{menu} if $for && $for ne $into; + return $self->{menu} || $self->reload_menu($into); +} + +sub reload_menu { + my $self = shift; + my ($into) = @_; + + $self->croak("reload_menu() requires the name of the destination package") + unless $into; + + my $from = $self->from; + + if (my $menu_sub = *{"$from\::IMPORTER_MENU"}{CODE}) { + # Hook, other exporter modules can define this method to be compatible with + # Importer.pm + + my %got = $from->$menu_sub($into, $self->get_caller); + + $got{export} ||= []; + $got{export_ok} ||= []; + $got{export_tags} ||= {}; + $got{export_fail} ||= []; + $got{export_anon} ||= {}; + $got{export_magic} ||= {}; + + $self->croak("'$from' provides both 'generate' and 'export_gen' in its IMPORTER_MENU (They are exclusive, module must pick 1)") + if $got{export_gen} && $got{generate}; + + $got{export_gen} ||= {}; + + $self->{menu} = $self->_build_menu($into => \%got, 1); + } + else { + my %got; + $got{export} = \@{"$from\::EXPORT"}; + $got{export_ok} = \@{"$from\::EXPORT_OK"}; + $got{export_tags} = \%{"$from\::EXPORT_TAGS"}; + $got{export_fail} = \@{"$from\::EXPORT_FAIL"}; + $got{export_gen} = \%{"$from\::EXPORT_GEN"}; + $got{export_anon} = \%{"$from\::EXPORT_ANON"}; + $got{export_magic} = \%{"$from\::EXPORT_MAGIC"}; + + $self->{menu} = $self->_build_menu($into => \%got, 0); + } + + $self->{menu_for} = $into; + + return $self->{menu}; +} + +sub _build_menu { + my $self = shift; + my ($into, $got, $new_style) = @_; + + my $from = $self->from; + + my $export = $got->{export} || []; + my $export_ok = $got->{export_ok} || []; + my $export_tags = $got->{export_tags} || {}; + my $export_fail = $got->{export_fail} || []; + my $export_anon = $got->{export_anon} || {}; + my $export_gen = $got->{export_gen} || {}; + my $export_magic = $got->{export_magic} || {}; + + my $generate = $got->{generate}; + + $generate ||= sub { + my $symbol = shift; + my ($sig, $name) = ($symbol =~ m/^(\W?)(.*)$/); + $sig ||= '&'; + + my $do = $export_gen->{"${sig}${name}"}; + $do ||= $export_gen->{$name} if !$sig || $sig eq '&'; + + return undef unless $do; + + $from->$do($into, $symbol); + } if $export_gen && keys %$export_gen; + + my $lookup = {}; + my $exports = {}; + for my $sym (@$export, @$export_ok, keys %$export_gen, keys %$export_anon) { + my ($sig, $name) = ($sym =~ m/^(\W?)(.*)$/); + $sig ||= '&'; + + $lookup->{"${sig}${name}"} = 1; + $lookup->{$name} = 1 if $sig eq '&'; + + next if $export_gen->{"${sig}${name}"}; + next if $sig eq '&' && $export_gen->{$name}; + next if $got->{generate} && $generate->("${sig}${name}"); + + my $fqn = "$from\::$name"; + # We cannot use *{$fqn}{TYPE} here, it breaks for autoloaded subs, this + # does not: + $exports->{"${sig}${name}"} = $export_anon->{$sym} || ( + $sig eq '&' ? \&{$fqn} : + $sig eq '$' ? \${$fqn} : + $sig eq '@' ? \@{$fqn} : + $sig eq '%' ? \%{$fqn} : + $sig eq '*' ? \*{$fqn} : + # Sometimes people (CGI::Carp) put invalid names (^name=) into + # @EXPORT. We simply go to 'next' in these cases. These modules + # have hooks to prevent anyone actually trying to import these. + next + ); + } + + my $f_import = $new_style || $from->can('import'); + $self->croak("'$from' does not provide any exports") + unless $new_style + || keys %$exports + || $from->isa('Exporter') + || ($INC{'Exporter.pm'} && $f_import && $f_import == \&Exporter::import); + + # Do not cleanup or normalize the list added to the DEFAULT tag, legacy.... + my $tags = { + %$export_tags, + 'DEFAULT' => [ @$export ], + }; + + # Add 'ALL' tag unless already specified. We want to normalize it. + $tags->{ALL} ||= [ sort grep {m/^[\&\$\@\%\*]/} keys %$lookup ]; + + my $fail = @$export_fail ? { + map { + my ($sig, $name) = (m/^(\W?)(.*)$/); + $sig ||= '&'; + ("${sig}${name}" => 1, $sig eq '&' ? ($name => 1) : ()) + } @$export_fail + } : undef; + + my $menu = { + lookup => $lookup, + exports => $exports, + tags => $tags, + fail => $fail, + generate => $generate, + magic => $export_magic, + }; + + return $menu; +} + +sub parse_args { + my $self = shift; + my ($into, @args) = @_; + + my $menu = $self->menu($into); + + my @out = $self->_parse_args($into, $menu, \@args); + pop @out; + return @out; +} + +sub _parse_args { + my $self = shift; + my ($into, $menu, $args, $is_tag) = @_; + + my $from = $self->from; + my $main_menu = $self->menu($into); + $menu ||= $main_menu; + + # First we strip out versions numbers and setters, this simplifies the logic late. + my @sets; + my @versions; + my @leftover; + for my $arg (@$args) { + no warnings 'void'; + + # Code refs are custom setters + # If the first character is an ASCII numeric then it is a version number + push @sets => $arg and next if ref($arg) eq 'CODE'; + push @versions => $arg xor next if $NUMERIC{substr($arg, 0, 1)}; + push @leftover => $arg; + } + + $self->carp("Multiple setters specified, only 1 will be used") if @sets > 1; + my $set = pop @sets; + + $args = \@leftover; + @$args = (':DEFAULT') unless $is_tag || @$args || @versions; + + my %exclude; + my @import; + + while(my $full_arg = shift @$args) { + my $arg = $full_arg; + my $lead = substr($arg, 0, 1); + + my ($spec, $exc); + if ($lead eq '!') { + $exc = $lead; + + if ($arg eq '!') { + # If the current arg is just '!' then we are negating the next item. + $arg = shift @$args; + } + else { + # Strip off the '!' + substr($arg, 0, 1, ''); + } + + # Exporter.pm legacy behavior + # negated first item implies starting with default set: + unshift @$args => ':DEFAULT' unless @import || keys %exclude || @versions; + + # Now we have a new lead character + $lead = substr($arg, 0, 1); + } + else { + # If the item is followed by a reference then they are asking us to + # do something special... + $spec = ref($args->[0]) eq 'HASH' ? shift @$args : {}; + } + + if($lead eq ':') { + substr($arg, 0, 1, ''); + my $tag = $menu->{tags}->{$arg} or $self->croak("$from does not export the :$arg tag"); + + my (undef, $cvers, $cexc, $cimp, $cset, $newmenu) = $self->_parse_args($into, $menu, $tag, $arg); + + $self->croak("Exporter specified version numbers (" . join(', ', @$cvers) . ") in the :$arg tag!") + if @$cvers; + + $self->croak("Exporter specified a custom symbol setter in the :$arg tag!") + if $cset; + + # Merge excludes + %exclude = (%exclude, %$cexc); + + if ($exc) { + $exclude{$_} = 1 for grep {!ref($_) && substr($_, 0, 1) ne '+'} map {$_->[0]} @$cimp; + } + elsif ($spec && keys %$spec) { + $self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg") + if $spec->{'-as'} && @$cimp > 1; + + for my $set (@$cimp) { + my ($sym, $cspec) = @$set; + + # Start with a blind squash, spec from tag overrides the ones inside. + my $nspec = {%$cspec, %$spec}; + + $nspec->{'-prefix'} = "$spec->{'-prefix'}$cspec->{'-prefix'}" if $spec->{'-prefix'} && $cspec->{'-prefix'}; + $nspec->{'-postfix'} = "$cspec->{'-postfix'}$spec->{'-postfix'}" if $spec->{'-postfix'} && $cspec->{'-postfix'}; + + push @import => [$sym, $nspec]; + } + } + else { + push @import => @$cimp; + } + + # New menu + $menu = $newmenu; + + next; + } + + # Process the item to figure out what symbols are being touched, if it + # is a tag or regex than it can be multiple. + my @list; + if(ref($arg) eq 'Regexp') { + @list = sort grep /$arg/, keys %{$menu->{lookup}}; + } + elsif($lead eq '/' && $arg =~ m{^/(.*)/$}) { + my $pattern = $1; + @list = sort grep /$1/, keys %{$menu->{lookup}}; + } + else { + @list = ($arg); + } + + # Normalize list, always have a sigil + @list = map {m/^\W/ ? $_ : "\&$_" } @list; + + if ($exc) { + $exclude{$_} = 1 for @list; + } + else { + $self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg") + if $spec->{'-as'} && @list > 1; + + push @import => [$_, $spec] for @list; + } + } + + return ($into, \@versions, \%exclude, \@import, $set, $menu); +} + +sub _handle_fail { + my $self = shift; + my ($into, $import) = @_; + + my $from = $self->from; + my $menu = $self->menu($into); + + # Historically Exporter would strip the '&' off of sub names passed into export_fail. + my @fail = map {my $x = $_->[0]; $x =~ s/^&//; $x} grep $menu->{fail}->{$_->[0]}, @$import or return; + + my @real_fail = $from->can('export_fail') ? $from->export_fail(@fail) : @fail; + + if (@real_fail) { + $self->carp(qq["$_" is not implemented by the $from module on this architecture]) + for @real_fail; + + $self->croak("Can't continue after import errors"); + } + + $self->reload_menu($menu); + return; +} + +sub _set_symbols { + my $self = shift; + my ($into, $exclude, $import, $custom_set) = @_; + + my $from = $self->from; + my $menu = $self->menu($into); + my $caller = $self->get_caller(); + + my $set_symbol = $custom_set || eval <<" EOT" || die $@; +# Inherit the callers warning settings. If they have warnings and we +# redefine their subs they will hear about it. If they do not have warnings +# on they will not. +BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] } +#line $caller->[2] "$caller->[1]" +sub { *{"$into\\::\$_[0]"} = \$_[1] } + EOT + + for my $set (@$import) { + my ($symbol, $spec) = @$set; + + my ($sig, $name) = ($symbol =~ m/^(\W)(.*)$/) or die "Invalid symbol: $symbol"; + + # Find the thing we are actually shoving in a new namespace + my $ref = $menu->{exports}->{$symbol}; + $ref ||= $menu->{generate}->($symbol) if $menu->{generate}; + + # Exporter.pm supported listing items in @EXPORT that are not actually + # available for export. So if it is listed (lookup) but nothing is + # there (!$ref) we simply skip it. + $self->croak("$from does not export $symbol") unless $ref || $menu->{lookup}->{"${sig}${name}"}; + next unless $ref; + + my $type = ref($ref); + $type = 'SCALAR' if $type eq 'REF'; + $self->croak("Symbol '$sig$name' requested, but reference (" . ref($ref) . ") does not match sigil ($sig)") + if $ref && $type ne $SIG_TO_SLOT{$sig}; + + # If they directly renamed it then we assume they want it under the new + # name, otherwise excludes get kicked. It is useful to be able to + # exclude an item in a tag/match where the group has a prefix/postfix. + next if $exclude->{"${sig}${name}"} && !$spec->{'-as'}; + + my $new_name = join '' => ($spec->{'-prefix'} || '', $spec->{'-as'} || $name, $spec->{'-postfix'} || ''); + + # Set the symbol (finally!) + $set_symbol->($new_name, $ref, sig => $sig, symbol => $symbol, into => $into, from => $from, spec => $spec); + + # The remaining things get skipped with a custom setter + next if $custom_set; + + # Record the import so that we can 'unimport' + push @{$IMPORTED{$into}} => $new_name if $sig eq '&'; + + # Apply magic + my $magic = $menu->{magic}->{$symbol}; + $magic ||= $menu->{magic}->{$name} if $sig eq '&'; + $from->$magic(into => $into, orig_name => $name, new_name => $new_name, ref => $ref) + if $magic; + } +} + +########################################################################### +# +# The rest of these are utility functions, not methods! +# + +sub _version_check { + my ($mod, $caller, @versions) = @_; + + eval <<" EOT" or die $@; +#line $caller->[2] "$caller->[1]" +\$mod->VERSION(\$_) for \@versions; +1; + EOT +} + +sub _mod_to_file { + my $file = shift; + $file =~ s{::}{/}g; + $file .= '.pm'; + return $file; +} + +sub _load_file { + my ($caller, $file) = @_; + + eval <<" EOT" || die $@; +#line $caller->[2] "$caller->[1]" +require \$file; + EOT +} + + +my %HEAVY_VARS = ( + IMPORTER_MENU => 'CODE', # Origin package has a custom menu + EXPORT_FAIL => 'ARRAY', # Origin package has a failure handler + EXPORT_GEN => 'HASH', # Origin package has generators + EXPORT_ANON => 'HASH', # Origin package has anonymous exports + EXPORT_MAGIC => 'HASH', # Origin package has magic to apply post-export +); + +sub optimal_import { + my ($from, $into, $caller, @args) = @_; + + defined(*{"$from\::$_"}{$HEAVY_VARS{$_}}) and return 0 for keys %HEAVY_VARS; + + # Default to @EXPORT + @args = @{"$from\::EXPORT"} unless @args; + + # Subs will be listed without sigil in %allowed, all others keep sigil + my %allowed = map +(substr($_, 0, 1) eq '&' ? substr($_, 1) : $_ => 1), + @{"$from\::EXPORT"}, @{"$from\::EXPORT_OK"}; + + # First check if it is allowed, stripping '&' if necessary, which will also + # let scalars in, we will deal with those shortly. + # If not allowed return 0 (need to do a heavy import) + # if it is allowed then see if it has a CODE slot, if so use it, otherwise + # we have a symbol that needs heavy due to non-sub, autoload, etc. + # This will not allow $foo to import foo() since '$from' still contains the + # sigil making it an invalid symbol name in our globref below. + my %final = map +( + (!ref($_) && ($allowed{$_} || (substr($_, 0, 1, "") eq '&' && $allowed{$_}))) + ? ($_ => *{"$from\::$_"}{CODE} || return 0) + : return 0 + ), @args; + + eval <<" EOT" || die $@; +# If the caller has redefine warnings enabled then we want to warn them if +# their import redefines things. +BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] }; +#line $caller->[2] "$caller->[1]" +(*{"$into\\::\$_"} = \$final{\$_}, push \@{\$Test2::Util::Importer::IMPORTED{\$into}} => \$_) for keys %final; +1; + EOT +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Importer - Inline copy of L. + +=head1 DESCRIPTION + +See L. + +=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 2023 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L + +=cut diff --git a/cpan/Test2-Suite/lib/Test2/Util/Ref.pm b/cpan/Test2-Suite/lib/Test2/Util/Ref.pm new file mode 100644 index 000000000000..7627d81e6b45 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Ref.pm @@ -0,0 +1,125 @@ +package Test2::Util::Ref; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Scalar::Util qw/reftype blessed refaddr/; + +our @EXPORT_OK = qw/rtype render_ref/; +use base 'Exporter'; + +sub rtype { + my ($thing) = @_; + return '' unless defined $thing; + + my $rf = ref $thing; + my $rt = reftype $thing; + + return '' unless $rf || $rt; + return 'REGEXP' if $rf =~ m/Regex/i; + return 'REGEXP' if $rt =~ m/Regex/i; + return $rt || ''; +} + +sub render_ref { + my ($in) = @_; + + return 'undef' unless defined($in); + + my $type = rtype($in); + return "$in" unless $type; + + # Look past overloading + my $class = blessed($in) || ''; + + my $it = sprintf('0x%x', refaddr($in)); + my $ref = "$type($it)"; + + return $ref unless $class; + + my $out = "$class=$ref"; + if ($class =~ m/bool/i) { + my $bool = $in ? 'TRUE' : 'FALSE'; + return "<$bool: $out>"; + } + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Ref - Tools for inspecting or manipulating references. + +=head1 DESCRIPTION + +These are used by L to inspect, render, or manipulate references. + +=head1 EXPORTS + +All exports are optional. You must specify subs to import. + +=over 4 + +=item $type = rtype($ref) + +A normalization between C and C. + +Always returns a string. + +Returns C<'REGEXP'> for regex types + +Returns C<''> for non-refs + +Otherwise returns what C returns. + +=item $addr_str = render_ref($ref) + +Always returns a string. For unblessed references this returns something like +C<"SCALAR(0x...)">. For blessed references it returns +C<"My::Thing=SCALAR(0x...)">. The only difference between this and C<$add_str = +"$thing"> is that it ignores any overloading to ensure it is always the ref +address. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Util/Stash.pm b/cpan/Test2-Suite/lib/Test2/Util/Stash.pm new file mode 100644 index 000000000000..2cacf012e1a2 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Stash.pm @@ -0,0 +1,247 @@ +package Test2::Util::Stash; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; +use B; + +our @EXPORT_OK = qw{ + get_stash + get_glob + get_symbol + parse_symbol + purge_symbol + slot_to_sig sig_to_slot +}; +use base 'Exporter'; + +my %SIGMAP = ( + '&' => 'CODE', + '$' => 'SCALAR', + '%' => 'HASH', + '@' => 'ARRAY', +); + +my %SLOTMAP = reverse %SIGMAP; + +sub slot_to_sig { $SLOTMAP{$_[0]} || croak "unsupported slot: '$_[0]'" } +sub sig_to_slot { $SIGMAP{$_[0]} || croak "unsupported sigil: $_[0]" } + +sub get_stash { + my $package = shift || caller; + no strict 'refs'; + return \%{"${package}\::"}; +} + +sub get_glob { + my $sym = _parse_symbol(scalar(caller), @_); + no strict 'refs'; + no warnings 'once'; + return \*{"$sym->{package}\::$sym->{name}"}; +} + +sub parse_symbol { _parse_symbol(scalar(caller), @_) } + +sub _parse_symbol { + my ($caller, $symbol, $package) = @_; + + if (ref($symbol)) { + my $pkg = $symbol->{package}; + + croak "Symbol package ($pkg) and package argument ($package) do not match" + if $pkg && $package && $pkg ne $package; + + $symbol->{package} ||= $caller; + + return $symbol; + } + + utf8::downgrade($symbol) if $] == 5.010000; # prevent crash on 5.10.0 + my ($sig, $pkg, $name) = ($symbol =~ m/^(\W?)(.*::)?([^:]+)$/) + or croak "Invalid symbol: '$symbol'"; + + # Normalize package, '::' becomes 'main', 'Foo::' becomes 'Foo' + $pkg = $pkg + ? $pkg eq '::' + ? 'main' + : substr($pkg, 0, -2) + : undef; + + croak "Symbol package ($pkg) and package argument ($package) do not match" + if $pkg && $package && $pkg ne $package; + + $sig ||= '&'; + my $type = $SIGMAP{$sig} || croak "unsupported sigil: '$sig'"; + + my $real_package = $package || $pkg || $caller; + + return { + name => $name, + sigil => $sig, + type => $type, + symbol => "${sig}${real_package}::${name}", + package => $real_package, + }; +} + +sub get_symbol { + my $sym = _parse_symbol(scalar(caller), @_); + + my $name = $sym->{name}; + my $type = $sym->{type}; + my $package = $sym->{package}; + my $symbol = $sym->{symbol}; + + my $stash = get_stash($package); + return undef unless exists $stash->{$name}; + + my $glob = get_glob($sym); + return *{$glob}{$type} if $type ne 'SCALAR' && defined(*{$glob}{$type}); + + if ($] < 5.010) { + return undef unless defined(*{$glob}{$type}); + + { + local ($@, $!); + local $SIG{__WARN__} = sub { 1 }; + return *{$glob}{$type} if eval "package $package; my \$y = $symbol; 1"; + } + + return undef unless defined *{$glob}{$type}; + return *{$glob}{$type} if defined ${*{$glob}{$type}}; + return undef; + } + + my $sv = B::svref_2object($glob)->SV; + return *{$glob}{$type} if $sv->isa('B::SV'); + return undef unless $sv->isa('B::SPECIAL'); + return *{$glob}{$type} if $B::specialsv_name[$$sv] ne 'Nullsv'; + return undef; +} + +sub purge_symbol { + my $sym = _parse_symbol(scalar(caller), @_); + + local *GLOBCLONE = *{get_glob($sym)}; + delete get_stash($sym->{package})->{$sym->{name}}; + my $new_glob = get_glob($sym); + + for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) { + next if $type eq $sym->{type}; + my $ref = get_symbol({type => $type, name => 'GLOBCLONE', sigil => $SLOTMAP{$type}}, __PACKAGE__); + next unless $ref; + *$new_glob = $ref; + } + + return *GLOBCLONE{$sym->{type}}; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Stash - Utilities for manipulating stashes and globs. + +=head1 DESCRIPTION + +This is a collection of utilities for manipulating and inspecting package +stashes and globs. + +=head1 EXPORTS + +=over 4 + +=item $stash = get_stash($package) + +Gets the package stash. This is the same as C<$stash = \%Package::Name::>. + +=item $sym_spec = parse_symbol($symbol) + +=item $sym_spec = parse_symbol($symbol, $package) + +Parse a symbol name, and return a hashref with info about the symbol. + +C<$symbol> can be a simple name, or a fully qualified symbol name. The sigil is +optional, and C<&> is assumed if none is provided. If C<$symbol> is fully qualified, +and C<$package> is also provided, then the package of the symbol must match the +C<$package>. + +Returns a structure like this: + + return { + name => 'BAZ', + sigil => '$', + type => 'SCALAR', + symbol => '&Foo::Bar::BAZ', + package => 'Foo::Bar', + }; + +=item $glob_ref = get_glob($symbol) + +=item $glob_ref = get_glob($symbol, $package) + +Get a glob ref. Arguments are the same as for C. + +=item $ref = get_symbol($symbol) + +=item $ref = get_symbol($symbol, $package) + +Get a reference to the symbol. Arguments are the same as for C. + +=item $ref = purge_symbol($symbol) + +=item $ref = purge_symbol($symbol, $package) + +Completely remove the symbol from the package symbol table. Arguments are the +same as for C. A reference to the removed symbol is returned. + +=item $sig = slot_to_sig($slot) + +Convert a slot (like 'SCALAR') to a sigil (like '$'). + +=item $slot = sig_to_slot($sig) + +Convert a sigil (like '$') to a slot (like 'SCALAR'). + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Util/Sub.pm b/cpan/Test2-Suite/lib/Test2/Util/Sub.pm new file mode 100644 index 000000000000..7ccfdccb4d2e --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Sub.pm @@ -0,0 +1,220 @@ +package Test2::Util::Sub; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak carp/; +use B(); + +our @EXPORT_OK = qw{ + sub_info + sub_name + + gen_reader gen_writer gen_accessor +}; +use base 'Exporter'; + +sub gen_reader { + my $field = shift; + return sub { $_[0]->{$field} }; +} + +sub gen_writer { + my $field = shift; + return sub { $_[0]->{$field} = $_[1] }; +} + +sub gen_accessor { + my $field = shift; + return sub { + my $self = shift; + ($self->{$field}) = @_ if @_; + return $self->{$field}; + }; +} + +sub sub_name { + my ($sub) = @_; + + croak "sub_name requires a coderef as its only argument" + unless ref($sub) eq 'CODE'; + + my $cobj = B::svref_2object($sub); + my $name = $cobj->GV->NAME; + return $name; +} + +sub sub_info { + my ($sub, @all_lines) = @_; + my %in = map {$_ => 1} @all_lines; + + croak "sub_info requires a coderef as its first argument" + unless ref($sub) eq 'CODE'; + + my $cobj = B::svref_2object($sub); + my $name = $cobj->GV->NAME; + my $file = $cobj->FILE; + my $package = $cobj->GV->STASH->NAME; + + my $op = $cobj->START; + while ($op) { + push @all_lines => $op->line if $op->can('line'); + last unless $op->can('next'); + $op = $op->next; + } + + my ($start, $end, @lines); + if (@all_lines) { + @all_lines = sort { $a <=> $b } @all_lines; + ($start, $end) = ($all_lines[0], $all_lines[-1]); + + # Adjust start and end for the most common case of a multi-line block with + # parens on the lines before and after. + if ($start < $end) { + $start-- unless $start <= 1 || $in{$start}; + $end++ unless $in{$end}; + } + @lines = ($start, $end); + } + + return { + ref => $sub, + cobj => $cobj, + name => $name, + file => $file, + package => $package, + start_line => $start, + end_line => $end, + all_lines => \@all_lines, + lines => \@lines, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Sub - Tools for inspecting and manipulating subs. + +=head1 DESCRIPTION + +Utilities used by Test2::Tools to inspect and manipulate subroutines. + +=head1 EXPORTS + +All exports are optional, you must specify subs to import. + +=over 4 + +=item $name = sub_name(\&sub) + +Get the name of the sub. + +=item my $hr = sub_info(\&code) + +This returns a hashref with information about the sub: + + { + ref => \&code, + cobj => $cobj, + name => "Some::Mod::code", + file => "Some/Mod.pm", + package => "Some::Mod", + + # Note: These have been adjusted based on guesswork. + start_line => 22, + end_line => 42, + lines => [22, 42], + + # Not a bug, these lines are different! + all_lines => [23, 25, ..., 39, 41], + }; + +=over 4 + +=item $info->{ref} => \&code + +This is the original sub passed to C. + +=item $info->{cobj} => $cobj + +This is the c-object representation of the coderef. + +=item $info->{name} => "Some::Mod::code" + +This is the name of the coderef. For anonymous coderefs this may end with +C<'__ANON__'>. Also note that the package 'main' is special, and 'main::' may +be omitted. + +=item $info->{file} => "Some/Mod.pm" + +The file in which the sub was defined. + +=item $info->{package} => "Some::Mod" + +The package in which the sub was defined. + +=item $info->{start_line} => 22 + +=item $info->{end_line} => 42 + +=item $info->{lines} => [22, 42] + +These three fields are the I start line, end line, and array with both. +It is important to note that these lines have been adjusted and may not be +accurate. + +The lines are obtained by walking the ops. As such, the first line is the line +of the first statement, and the last line is the line of the last statement. +This means that in multi-line subs the lines are usually off by 1. The lines +in these keys will be adjusted for you if it detects a multi-line sub. + +=item $info->{all_lines} => [23, 25, ..., 39, 41] + +This is an array with the lines of every statement in the sub. Unlike the other +line fields, these have not been adjusted for you. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Util/Table.pm b/cpan/Test2-Suite/lib/Test2/Util/Table.pm new file mode 100644 index 000000000000..0884fc012a76 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Table.pm @@ -0,0 +1,199 @@ +package Test2::Util::Table; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use base 'Term::Table'; + +use Test2::Util::Importer 'Test2::Util::Importer' => 'import'; +our @EXPORT_OK = qw/table/; +our %EXPORT_GEN = ( + '&term_size' => sub { + require Carp; + Carp::cluck "term_size should be imported from Test2::Util::Term, not " . __PACKAGE__; + Test2::Util::Term->can('term_size'); + }, +); + +sub table { + my %params = @_; + + $params{collapse} ||= 0; + $params{sanitize} ||= 0; + $params{mark_tail} ||= 0; + $params{show_header} ||= 0 unless $params{header} && @{$params{header}}; + + __PACKAGE__->new(%params)->render; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Table - Format a header and rows into a table + +=head1 DESCRIPTION + +This is used by some failing tests to provide diagnostics about what has gone +wrong. This module is able to generic format rows of data into tables. + +=head1 SYNOPSIS + + use Test2::Util::Table qw/table/; + + my @table = table( + max_width => 80, + collapse => 1, # Do not show empty columns + header => [ 'name', 'age', 'hair color' ], + rows => [ + [ 'Fred Flinstone', 2000000, 'black' ], + [ 'Wilma Flinstone', 1999995, 'red' ], + ..., + ], + ); + + # The @table array contains each line of the table, no newlines added. + say $_ for @table; + +This prints a table like this: + + +-----------------+---------+------------+ + | name | age | hair color | + +-----------------+---------+------------+ + | Fred Flinstone | 2000000 | black | + | Wilma Flinstone | 1999995 | red | + | ... | ... | ... | + +-----------------+---------+------------+ + +=head1 EXPORTS + +=head2 @rows = table(...) + +The function returns a list of lines, lines do not have the newline C<\n> +character appended. + +Options: + +=over 4 + +=item header => [ ... ] + +If you want a header specify it here. This takes an arrayref with each columns +heading. + +=item rows => [ [...], [...], ... ] + +This should be an arrayref containing an arrayref per row. + +=item collapse => $bool + +Use this if you want to hide empty columns, that is any column that has no data +in any row. Having a header for the column will not effect collapse. + +=item max_width => $num + +Set the maximum width of the table, the table may not be this big, but it will +be no bigger. If none is specified it will attempt to find the width of your +terminal and use that, otherwise it falls back to C<80>. + +=item sanitize => $bool + +This will sanitize all the data in the table such that newlines, control +characters, and all whitespace except for ASCII 20 C<' '> are replaced with +escape sequences. This prevents newlines, tabs, and similar whitespace from +disrupting the table. + +B newlines are marked as '\n', but a newline is also inserted into the +data so that it typically displays in a way that is useful to humans. + +Example: + + my $field = "foo\nbar\nbaz\n"; + + print join "\n" => table( + sanitize => 1, + rows => [ + [$field, 'col2' ], + ['row2 col1', 'row2 col2'] + ] + ); + +Prints: + + +-----------------+-----------+ + | foo\n | col2 | + | bar\n | | + | baz\n | | + | | | + | row2 col1 | row2 col2 | + +-----------------+-----------+ + +So it marks the newlines by inserting the escape sequence, but it also shows +the data across as many lines as it would normally display. + +=item mark_tail => $bool + +This will replace the last whitespace character of any trailing whitespace with +its escape sequence. This makes it easier to notice trailing whitespace when +comparing values. + +=back + +=head2 my $cols = term_size() + +Attempts to find the width in columns (characters) of the current terminal. +Returns 80 as a safe bet if it cannot find it another way. + +=head1 NOTE ON UNICODE/WIDE CHARACTERS + +Some unicode characters, such as C<婧> (C) are wider than others. These +will render just fine if you C as necessary, and +L is installed, however if the module is not installed there +will be anomalies in the table: + + +-----+-----+---+ + | a | b | c | + +-----+-----+---+ + | 婧 | x | y | + | x | y | z | + | x | 婧 | z | + +-----+-----+---+ + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Util/Table/Cell.pm b/cpan/Test2-Suite/lib/Test2/Util/Table/Cell.pm new file mode 100644 index 000000000000..a92285a8695b --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Table/Cell.pm @@ -0,0 +1,9 @@ +package Test2::Util::Table::Cell; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use base 'Term::Table::Cell'; + +1; diff --git a/cpan/Test2-Suite/lib/Test2/Util/Table/LineBreak.pm b/cpan/Test2-Suite/lib/Test2/Util/Table/LineBreak.pm new file mode 100644 index 000000000000..41504b1011ad --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Table/LineBreak.pm @@ -0,0 +1,67 @@ +package Test2::Util::Table::LineBreak; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use base 'Term::Table::LineBreak'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Table::LineBreak - Break up lines for use in tables. + +=head1 DESCRIPTION + +This is meant for internal use. This package takes long lines of text and +splits them so that they fit in table rows. + +=head1 SYNOPSIS + + use Test2::Util::Table::LineBreak; + + my $lb = Test2::Util::Table::LineBreak->new(string => $STRING); + + $lb->break($SIZE); + while (my $part = $lb->next) { + ... + } + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Util/Term.pm b/cpan/Test2-Suite/lib/Test2/Util/Term.pm new file mode 100644 index 000000000000..7956f0020e4a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Term.pm @@ -0,0 +1,12 @@ +package Test2::Util::Term; +use strict; +use warnings; + +use Term::Table::Util qw/term_size USE_GCS USE_TERM_READKEY uni_length/; + +our $VERSION = '0.000156'; + +use Test2::Util::Importer 'Test2::Util::Importer' => 'import'; +our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY uni_length/; + +1; diff --git a/cpan/Test2-Suite/lib/Test2/Util/Times.pm b/cpan/Test2-Suite/lib/Test2/Util/Times.pm new file mode 100644 index 000000000000..22bc0484bfd2 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Util/Times.pm @@ -0,0 +1,138 @@ +package Test2::Util::Times; +use strict; +use warnings; + +use List::Util qw/sum/; + +our $VERSION = '0.000156'; + +our @EXPORT_OK = qw/render_bench render_duration/; +use base 'Exporter'; + +sub render_duration { + my $time; + if (@_ == 1) { + ($time) = @_; + } + else { + my ($start, $end) = @_; + $time = $end - $start; + } + + return sprintf('%1.5fs', $time) if $time < 10; + return sprintf('%2.4fs', $time) if $time < 60; + + my $msec = substr(sprintf('%0.2f', $time - int($time)), -2, 2); + my $secs = $time % 60; + my $mins = int($time / 60) % 60; + my $hours = int($time / 60 / 60) % 24; + my $days = int($time / 60 / 60 / 24); + + my @units = (qw/d h m/, ''); + + my $duration = ''; + for my $t ($days, $hours, $mins, $secs) { + my $u = shift @units; + next unless $t || $duration; + $duration = join ':' => grep { length($_) } $duration, sprintf('%02u%s', $t, $u); + } + + $duration ||= '0'; + $duration .= ".$msec" if int($msec); + $duration .= 's'; + + return $duration; +} + +sub render_bench { + my ($start, $end, $user, $system, $cuser, $csystem) = @_; + + my $duration = render_duration($start, $end); + + my $bench = sprintf( + "%s on wallclock (%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)", + $duration, $user, $system, $cuser, $csystem, sum($user, $system, $cuser, $csystem), + ); + $bench =~ s/\s+/ /g; + $bench =~ s/(\(|\))\s+/$1/g; + + return $bench; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Times - Format timing/benchmark information. + +=head1 DESCRIPTION + +This modules exports tools for rendering timing data at the end of tests. + +=head1 EXPORTS + +All exports are optional. You must specify subs to import. + +=over 4 + +=item $str = render_bench($start, $end, $user, $system, $cuser, $csystem) + +=item $str = render_bench($start, time(), times()) + +This will produce a string like one of these (Note these numbers are completely +made up). I + + 0.12345s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 11.1234s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 01m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + + 04d:18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU) + +The first 2 arguments are the C<$start> and C<$end> times in seconds (as +returned by C or C). + +The last 4 arguments are timing information as returned by the C +function. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/V0.pm b/cpan/Test2-Suite/lib/Test2/V0.pm new file mode 100644 index 000000000000..aff8998a232a --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/V0.pm @@ -0,0 +1,623 @@ +package Test2::V0; +use strict; +use warnings; + +use Test2::Util::Importer; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; + +use Test2::Plugin::SRand(); +use Test2::Plugin::UTF8(); +use Test2::Tools::Target(); + +use Test2::Plugin::ExitSummary; + +use Test2::API qw/intercept context/; + +use Test2::Tools::Event qw/gen_event/; + +use Test2::Tools::Defer qw/def do_def/; + +use Test2::Tools::Basic qw{ + ok pass fail diag note todo skip + plan skip_all done_testing bail_out +}; + +use Test2::Tools::Compare qw{ + is like isnt unlike + match mismatch validator + hash array bag object meta meta_check number float rounded within string subset bool check_isa + number_lt number_le number_ge number_gt + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event fail_events + exact_ref +}; + +use Test2::Tools::Warnings qw{ + warns warning warnings no_warnings +}; + +use Test2::Tools::ClassicCompare qw/cmp_ok/; + +use Test2::Util::Importer 'Test2::Tools::Subtest' => ( + subtest_buffered => { -as => 'subtest' }, +); + +use Test2::Tools::Class qw/can_ok isa_ok DOES_ok/; +use Test2::Tools::Encoding qw/set_encoding/; +use Test2::Tools::Exports qw/imported_ok not_imported_ok/; +use Test2::Tools::Ref qw/ref_ok ref_is ref_is_not/; +use Test2::Tools::Mock qw/mock mocked/; +use Test2::Tools::Exception qw/try_ok dies lives/; +use Test2::Tools::Refcount qw/is_refcount is_oneref refcount/; + +our @EXPORT = qw{ + ok pass fail diag note todo skip + plan skip_all done_testing bail_out + + intercept context + + gen_event + + def do_def + + cmp_ok + + warns warning warnings no_warnings + + subtest + can_ok isa_ok DOES_ok + set_encoding + imported_ok not_imported_ok + ref_ok ref_is ref_is_not + mock mocked + dies lives try_ok + + is like isnt unlike + match mismatch validator + hash array bag object meta meta_check number float rounded within string subset bool check_isa + number_lt number_le number_ge number_gt + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event fail_events + exact_ref + + is_refcount is_oneref refcount +}; + +my $SRAND; +sub import { + my $class = shift; + + my $caller = caller; + my (@exports, %options); + while (my $arg = shift @_) { + push @exports => $arg and next unless substr($arg, 0, 1) eq '-'; + $options{$arg} = shift @_; + } + + # SRand handling + my $srand = delete $options{'-srand'}; + + my $no_srand = exists $options{'-no_srand'}; + delete $options{'-no_srand'} if $no_srand; + + croak "Cannot combine '-srand' and '-no_srand' options" + if $no_srand && defined($srand); + + if ( !$no_srand ) { + Test2::Plugin::SRand->import($srand ? $srand : ()) if defined($srand) || !$SRAND++; + } + + # Pragmas + my $no_pragmas = delete $options{'-no_pragmas'}; + my $no_strict = delete $options{'-no_strict'} || $no_pragmas; + my $no_warnings = delete $options{'-no_warnings'} || $no_pragmas; + my $no_utf8 = delete $options{'-no_utf8'} || $no_pragmas; + + strict->import() unless $no_strict; + 'warnings'->import() unless $no_warnings; + Test2::Plugin::UTF8->import() unless $no_utf8; + + my $target = delete $options{'-target'}; + Test2::Tools::Target->import_into($caller, $target) + if $target; + + croak "Unknown option(s): " . join(', ', sort keys %options) if keys %options; + + Test2::Util::Importer->import_into($class, $caller, @exports); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::V0 - 0Th edition of the Test2 recommended bundle. + +=head1 DESCRIPTION + +This is the big-daddy bundle. This bundle includes nearly every tool, and +several plugins, that the Test2 author uses. This bundle is used +extensively to test L itself. + +=head1 NAMING, USING, DEPENDING + +This bundle should not change in a I incompatible way. Some minor +breaking changes, specially bugfixes, may be allowed. If breaking changes are +needed then a new C module should be released instead. + +As new C modules are released old ones I be moved to different cpan +distributions. You should always use a specific bundle version and list that +version in your distributions testing requirements. You should never simply +list L as your modules dep, instead list the specific bundle, or +tools and plugins you use directly in your metadata. + +=head1 SYNOPSIS + + use Test2::V0; + + ok(1, "pass"); + + ... + + done_testing; + +=head1 RESOLVING CONFLICTS WITH MOOSE + + use Test2::V0 '!meta'; + +L and L both export very different C +subs. Adding C<'!meta'> to the import args will prevent the sub from being +imported. This bundle also exports the sub under the name C so +you can use that spelling as an alternative. + +=head2 TAGS + +=over 4 + +=item :DEFAULT + +The following are both identical: + + use Test2::V0; + + use Test2::V0 ':DEFAULT'; + +=back + +=head2 RENAMING ON IMPORT + + use Test2::V0 ':DEFAULT', '!ok', ok => {-as => 'my_ok'}; + +This bundle uses L for exporting, as such you can use any arguments +it accepts. + +Explanation: + +=over 4 + +=item '!ok' + +Do not export C + +=item ok => {-as => 'my_ok'} + +Actually, go ahead and import C but under the name C. + +=back + +If you did not add the C<'!ok'> argument then you would have both C and +C + +=head1 PRAGMAS + +All of these can be disabled via individual import arguments, or by the +C<-no_pragmas> argument. + + use Test2::V0 -no_pragmas => 1; + +=head2 STRICT + +L is turned on for you. You can disable this with the C<-no_strict> or +C<-no_pragmas> import arguments: + + use Test2::V0 -no_strict => 1; + +=head2 WARNINGS + +L are turned on for you. You can disable this with the +C<-no_warnings> or C<-no_pragmas> import arguments: + + use Test2::V0 -no_warnings => 1; + +=head2 UTF8 + +This is actually done via the L plugin, see the +L section for details. + +B C<< -no_pragmas => 1 >> will turn off the entire plugin. + +=head1 PLUGINS + +=head2 SRAND + +See L. + +This will set the random seed to today's date. You can provide an alternate seed +with the C<-srand> import option: + + use Test2::V0 -srand => 1234; + +=head2 UTF8 + +See L. + +This will set the file, and all output handles (including formatter handles), to +utf8. This will turn on the utf8 pragma for the current scope. + +This can be disabled using the C<< -no_utf8 => 1 >> or C<< -no_pragmas => 1 >> +import arguments. + + use Test2::V0 -no_utf8 => 1; + +=head2 EXIT SUMMARY + +See L. + +This plugin has no configuration. + +=head1 API FUNCTIONS + +See L for these + +=over 4 + +=item $ctx = context() + +=item $events = intercept { ... } + +=back + +=head1 TOOLS + +=head2 TARGET + +See L. + +You can specify a target class with the C<-target> import argument. If you do +not provide a target then C<$CLASS> and C will not be imported. + + use Test2::V0 -target => 'My::Class'; + + print $CLASS; # My::Class + print CLASS(); # My::Class + +Or you can specify names: + + use Test2::V0 -target => { pkg => 'Some::Package' }; + + pkg()->xxx; # Call 'xxx' on Some::Package + $pkg->xxx; # Same + +=over 4 + +=item $CLASS + +Package variable that contains the target class name. + +=item $class = CLASS() + +Constant function that returns the target class name. + +=back + +=head2 DEFER + +See L. + +=over 4 + +=item def $func => @args; + +=item do_def() + +=back + +=head2 BASIC + +See L. + +=over 4 + +=item ok($bool, $name) + +=item ok($bool, $name, @diag) + +=item pass($name) + +=item pass($name, @diag) + +=item fail($name) + +=item fail($name, @diag) + +=item diag($message) + +=item note($message) + +=item $todo = todo($reason) + +=item todo $reason => sub { ... } + +=item skip($reason, $count) + +=item plan($count) + +=item skip_all($reason) + +=item done_testing() + +=item bail_out($reason) + +=back + +=head2 COMPARE + +See L. + +=over 4 + +=item is($got, $want, $name) + +=item isnt($got, $do_not_want, $name) + +=item like($got, qr/match/, $name) + +=item unlike($got, qr/mismatch/, $name) + +=item $check = match(qr/pattern/) + +=item $check = mismatch(qr/pattern/) + +=item $check = validator(sub { return $bool }) + +=item $check = hash { ... } + +=item $check = array { ... } + +=item $check = bag { ... } + +=item $check = object { ... } + +=item $check = meta { ... } + +=item $check = number($num) + +=item $check = string($str) + +=item $check = check_isa($class_name) + +=item $check = in_set(@things) + +=item $check = not_in_set(@things) + +=item $check = check_set(@things) + +=item $check = item($thing) + +=item $check = item($idx => $thing) + +=item $check = field($name => $val) + +=item $check = call($method => $expect) + +=item $check = call_list($method => $expect) + +=item $check = call_hash($method => $expect) + +=item $check = prop($name => $expect) + +=item $check = check($thing) + +=item $check = T() + +=item $check = F() + +=item $check = D() + +=item $check = DF() + +=item $check = E() + +=item $check = DNE() + +=item $check = FDNE() + +=item $check = U() + +=item $check = L() + +=item $check = exact_ref($ref) + +=item end() + +=item etc() + +=item filter_items { grep { ... } @_ } + +=item $check = event $type => ... + +=item @checks = fail_events $type => ... + +=back + +=head2 CLASSIC COMPARE + +See L. + +=over 4 + +=item cmp_ok($got, $op, $want, $name) + +=back + +=head2 SUBTEST + +See L. + +=over 4 + +=item subtest $name => sub { ... }; + +(Note: This is called C in the Tools module.) + +=back + +=head2 CLASS + +See L. + +=over 4 + +=item can_ok($thing, @methods) + +=item isa_ok($thing, @classes) + +=item DOES_ok($thing, @roles) + +=back + +=head2 ENCODING + +See L. + +=over 4 + +=item set_encoding($encoding) + +=back + +=head2 EXPORTS + +See L. + +=over 4 + +=item imported_ok('function', '$scalar', ...) + +=item not_imported_ok('function', '$scalar', ...) + +=back + +=head2 REF + +See L. + +=over 4 + +=item ref_ok($ref, $type) + +=item ref_is($got, $want) + +=item ref_is_not($got, $do_not_want) + +=back + +See L. + +=over 4 + +=item is_refcount($ref, $count, $description) + +=item is_oneref($ref, $description) + +=item $count = refcount($ref) + +=back + +=head2 MOCK + +See L. + +=over 4 + +=item $control = mock ... + +=item $bool = mocked($thing) + +=back + +=head2 EXCEPTION + +See L. + +=over 4 + +=item $exception = dies { ... } + +=item $bool = lives { ... } + +=item $bool = try_ok { ... } + +=back + +=head2 WARNINGS + +See L. + +=over 4 + +=item $count = warns { ... } + +=item $warning = warning { ... } + +=item $warnings_ref = warnings { ... } + +=item $bool = no_warnings { ... } + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite 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 2018 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/cpan/Test2-Suite/lib/Test2/Workflow.pm b/cpan/Test2-Suite/lib/Test2/Workflow.pm new file mode 100644 index 000000000000..7c569e01e3b9 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Workflow.pm @@ -0,0 +1,288 @@ +package Test2::Workflow; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +our @EXPORT_OK = qw/parse_args current_build build root_build init_root build_stack/; +use base 'Exporter'; + +use Test2::Workflow::Build; +use Test2::Workflow::Task::Group; +use Test2::API qw/intercept/; +use Scalar::Util qw/blessed/; + +sub parse_args { + my %input = @_; + my $args = delete $input{args}; + my %out; + my %props; + + my $caller = $out{frame} = $input{caller} || caller(defined $input{level} ? $input{level} : 1); + delete @input{qw/caller level/}; + + for my $arg (@$args) { + if (my $r = ref($arg)) { + if ($r eq 'HASH') { + %props = (%props, %$arg); + } + elsif ($r eq 'CODE') { + die "Code is already set, did you provide multiple code blocks at $caller->[1] line $caller->[2].\n" + if $out{code}; + + $out{code} = $arg + } + else { + die "Not sure what to do with $arg at $caller->[1] line $caller->[2].\n"; + } + next; + } + + if ($arg =~ m/^\d+$/) { + push @{$out{lines}} => $arg; + next; + } + + die "Name is already set to '$out{name}', cannot set to '$arg', did you specify multiple names at $caller->[1] line $caller->[2].\n" + if $out{name}; + + $out{name} = $arg; + } + + die "a name must be provided, and must be truthy at $caller->[1] line $caller->[2].\n" + unless $out{name}; + + die "a codeblock must be provided at $caller->[1] line $caller->[2].\n" + unless $out{code}; + + return { %props, %out, %input }; +} + +{ + my %ROOT_BUILDS; + my @BUILD_STACK; + + sub root_build { $ROOT_BUILDS{$_[0]} } + sub current_build { @BUILD_STACK ? $BUILD_STACK[-1] : undef } + sub build_stack { @BUILD_STACK } + + sub init_root { + my ($pkg, %args) = @_; + $ROOT_BUILDS{$pkg} ||= Test2::Workflow::Build->new( + name => $pkg, + flat => 1, + iso => 0, + async => 0, + is_root => 1, + %args, + ); + + return $ROOT_BUILDS{$pkg}; + } + + sub build { + my %params = @_; + my $args = parse_args(%params); + + my $build = Test2::Workflow::Build->new(%$args); + + return $build if $args->{skip}; + + push @BUILD_STACK => $build; + + my ($ok, $err); + my $events = intercept { + my $todo = $args->{todo} ? Test2::Todo->new(reason => $args->{todo}) : undef; + $ok = eval { $args->{code}->(); 1 }; + $err = $@; + $todo->end if $todo; + }; + + # Clear the stash + $build->{stash} = []; + $build->set_events($events); + + pop @BUILD_STACK; + + unless($ok) { + my $hub = Test2::API::test2_stack->top; + my $count = @$events; + my $list = $count + ? "Overview of unseen events:\n" . join "" => map " " . blessed($_) . " " . $_->trace($hub)->debug . "\n", @$events + : ""; + die <<" EOT"; +Exception in build '$args->{name}' with $count unseen event(s). +$err +$list + EOT + } + + return $build; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Workflow - A test workflow is a way of structuring tests using +composable units. + +=head1 DESCRIPTION + +A test workflow is a way of structuring tests using composable units. A well +known example of a test workflow is L. RSPEC is +implemented using Test2::Workflow in L along with several +extensions. + +=head1 IMPORTANT CONCEPTS + +=head2 BUILD + +L + +A Build is used to compose tasks. Usually a build object is pushed to the stack +before running code that adds tasks to the build. Once the build sub is +complete the build is popped and returned. Usually a build is converted into a +root task or task group. + +=head2 RUNNER + +L + +A runner takes the composed tasks and executes them in the proper order. + +=head2 TASK + +L + +A task is a unit of work to accomplish. There are 2 main types of task. + +=head3 ACTION + +An action is the most simple unit used in composition. An action is essentially +a name and a codeblock to run. + +=head3 GROUP + +A group is a task that is composed of other tasks. + +=head1 EXPORTS + +All exports are optional, you must request the ones you want. + +=over 4 + +=item $parsed = parse_args(args => \@args) + +=item $parsed = parse_args(args => \@args, level => $L) + +=item $parsed = parse_args(args => \@args, caller => [caller($L)]) + +This will parse a "typical" task builders arguments. The C<@args> array MUST +contain a name (plain scalar containing text) and also a single CODE reference. +The C<@args> array MAY also contain any quantity of line numbers or hashrefs. +The resulting data structure will be a single hashref with all the provided +hashrefs squashed together, and the 'name', 'code', 'lines' and 'frame' keys +set from other arguments. + + { + # All hashrefs from @args get squashed together: + %squashed_input_hashref_data, + + # @args must have exactly 1 plaintext scalar that is not a number, it + # is considered the name: + name => 'name from input args' + + # Integer values are treated as line numbers + lines => [ 35, 44 ], + + # Exactly 1 coderef must be provided in @args: + code => \&some_code, + + # 'frame' contains the 'caller' data. This may be passed in directly, + # obtained from the 'level' parameter, or automatically deduced. + frame => ['A::Package', 'a_file.pm', 42, ...], + } + +=item $build = init_root($pkg, %args) + +This will initialize (or return the existing) a build for the specified +package. C<%args> get passed into the L constructor. +This uses the following defaults (which can be overridden using C<%args>): + + name => $pkg, + flat => 1, + iso => 0, + async => 0, + is_root => 1, + +Note that C<%args> is completely ignored if the package build has already been +initialized. + +=item $build = root_build($pkg) + +This will return the root build for the specified package. + +=item $build = current_build() + +This will return the build currently at the top of the build stack (or undef). + +=item $build = build($name, \%params, sub { ... }) + +This will push a new build object onto the build stash then run the provided +codeblock. Once the codeblock has finished running the build will be popped off +the stack and returned. + +See C for details about argument processing. + +=back + +=head1 SEE ALSO + +=over 4 + +=item Test2::Tools::Spec + +L is an implementation of RSPEC using this library. + +=back + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/lib/Test2/Workflow/BlockBase.pm b/cpan/Test2-Suite/lib/Test2/Workflow/BlockBase.pm new file mode 100644 index 000000000000..2f460a37e5ac --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Workflow/BlockBase.pm @@ -0,0 +1,159 @@ +package Test2::Workflow::BlockBase; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Util::HashBase qw/code frame _info _lines/; +use Test2::Util::Sub qw/sub_info/; +use List::Util qw/min max/; +use Carp qw/croak/; + +use Test2::Util::Trace(); + +BEGIN { + local ($@, $!, $SIG{__DIE__}); + + my $set_name = eval { require Sub::Util; Sub::Util->can('set_subname') } + || eval { require Sub::Name; Sub::Name->can('subname') }; + + *set_subname = $set_name ? sub { + my $self = shift; + my ($name) = @_; + + $set_name->($name, $self->{+CODE}); + delete $self->{+_INFO}; + + return 1; + } : sub { return 0 }; +} + +sub init { + my $self = shift; + + croak "The 'code' attribute is required" + unless $self->{+CODE}; + + croak "The 'frame' attribute is required" + unless $self->{+FRAME}; + + $self->{+_LINES} = delete $self->{lines} + if $self->{lines}; +} + +sub file { shift->info->{file} } +sub lines { shift->info->{lines} } +sub package { shift->info->{package} } +sub subname { shift->info->{name} } + +sub info { + my $self = shift; + + unless ($self->{+_INFO}) { + my $info = sub_info($self->code); + + my $frame = $self->frame; + my $file = $info->{file}; + my $all_lines = $info->{all_lines}; + my $pre_lines = $self->{+_LINES}; + my $lines = $info->{lines} ||= []; + + if ($pre_lines && @$pre_lines) { + @$lines = @$pre_lines; + } + else { + @$lines = ( + min(@$all_lines, $frame->[2]), + max(@$all_lines, $frame->[2]), + ) if $frame->[1] eq $file; + } + + # Adjust for start + $lines->[0]-- if $lines->[0] != $lines->[1]; + + $self->{+_INFO} = $info; + } + + return $self->{+_INFO}; +} + +sub trace { + my $self = shift; + + my ($hub, %params) = @_; + + croak "'hub' is required" + unless $hub; + + return Test2::Util::Trace->new( + frame => $self->frame, + detail => $self->debug, + + buffered => $hub->buffered, + nested => $hub->nested, + hid => $hub->hid, + huuid => $hub->uuid, + + %params, + ); +} + +sub debug { + my $self = shift; + my $file = $self->file; + my $lines = $self->lines; + + my $line_str = @$lines == 1 ? "around line $lines->[0]" : "around lines $lines->[0] -> $lines->[1]"; + return "at $file $line_str."; +} + +sub throw { + my $self = shift; + my ($msg) = @_; + die "$msg " . $self->debug . "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Workflow::BlockBase - Base class for all workflow blocks. + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/lib/Test2/Workflow/Build.pm b/cpan/Test2-Suite/lib/Test2/Workflow/Build.pm new file mode 100644 index 000000000000..2c4aa63f67e1 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Workflow/Build.pm @@ -0,0 +1,165 @@ +package Test2::Workflow::Build; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::Workflow::Task::Group; + +our @BUILD_FIELDS; + +BEGIN { + @BUILD_FIELDS = qw{ + primary variant + setup teardown + variant_setup variant_teardown + primary_setup primary_teardown + stash + }; +} + +use base 'Test2::Workflow::Task'; +use Test2::Util::HashBase @BUILD_FIELDS, qw/events defaults stack_stop/; + +sub init { + my $self = shift; + + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $self->SUPER::init(); + } + + $self->{$_} ||= [] for @BUILD_FIELDS; + $self->{+DEFAULTS} ||= {}; +} + +for my $field (@BUILD_FIELDS) { + my $code = sub { + my $self = shift; + push @{$self->{$field}} => @_; + }; + no strict 'refs'; + *{"add_$field"} = $code; +} + +sub populated { + my $self = shift; + for my $field (@BUILD_FIELDS) { + return 1 if @{$self->{$field}}; + } + return 0; +} + +sub compile { + my $self = shift; + + warn "Workflow build '$self->{+NAME}' is empty " . $self->debug . "\n" + unless $self->populated || $self->{+SKIP}; + + my ($primary_setup, $primary_teardown) = @_; + $primary_setup ||= []; + $primary_teardown ||= []; + + my $variant = $self->{+VARIANT}; + my $setup = $self->{+SETUP}; + my $teardown = $self->{+TEARDOWN}; + my $variant_setup = $self->{+VARIANT_SETUP}; + my $variant_teardown = $self->{+VARIANT_TEARDOWN}; + + $primary_setup = [@$primary_setup, @{$self->{+PRIMARY_SETUP}}]; + $primary_teardown = [@{$self->{+PRIMARY_TEARDOWN}}, @$primary_teardown]; + + # Get primaries in order. + my $primary = [ + map { + $_->isa(__PACKAGE__) + ? $_->compile($primary_setup, $primary_teardown) + : $_; + } @{$self->{+PRIMARY}}, + ]; + + if (@$primary_setup || @$primary_teardown) { + $primary = [ + map { + my $p = $_->clone; + $_->isa('Test2::Workflow::Task::Action') ? Test2::Workflow::Task::Group->new( + before => $primary_setup, + primary => [ $p ], + take => $p, + after => $primary_teardown, + ) : $_; + } @$primary + ]; + } + + # Build variants + if (@$variant) { + $primary = [ + map { + my $v = $_->clone; + Test2::Workflow::Task::Group->new( + before => $variant_setup, + primary => $primary, + after => $variant_teardown, + variant => $v, + take => $v, + ); + } @$variant + ]; + } + + my %params = map { Test2::Workflow::Task::Group->can($_) ? ($_ => $self->{$_}) : () } keys %$self; + delete $params{$_} for @BUILD_FIELDS; + + return Test2::Workflow::Task::Group->new( + %params, + before => $setup, + after => $teardown, + primary => $primary, + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Workflow::Build - Represents a build in progress. + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/lib/Test2/Workflow/Runner.pm b/cpan/Test2-Suite/lib/Test2/Workflow/Runner.pm new file mode 100644 index 000000000000..d2dd067347c8 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Workflow/Runner.pm @@ -0,0 +1,496 @@ +package Test2::Workflow::Runner; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API(); +use Test2::Todo(); +use Test2::AsyncSubtest(); + +use Test2::Util qw/get_tid CAN_REALLY_FORK/; + +use Scalar::Util qw/blessed/; +use Time::HiRes qw/sleep/; +use List::Util qw/shuffle min/; +use Carp qw/confess/; + +use Test2::Util::HashBase qw{ + stack no_fork no_threads max slots pid tid rand subtests filter +}; + +use overload( + 'fallback' => 1, + '&{}' => sub { + my $self = shift; + + sub { + @_ = ($self); + goto &run; + } + }, +); + +sub init { + my $self = shift; + + $self->{+STACK} = []; + $self->{+SUBTESTS} = []; + + $self->{+PID} = $$; + $self->{+TID} = get_tid(); + + $self->{+NO_FORK} ||= $ENV{T2_WORKFLOW_NO_FORK} || !CAN_REALLY_FORK(); + + my $can_thread = Test2::AsyncSubtest->CAN_REALLY_THREAD(); + my $should_thread = ($ENV{T2_WORKFLOW_USE_THREADS} || $ENV{T2_DO_THREAD_TESTS}) && !$ENV{T2_WORKFLOW_NO_THREADS}; + $self->{+NO_THREADS} ||= !($can_thread && $should_thread); + + $self->{+RAND} = 1 unless defined $self->{+RAND}; + + my @max = grep {defined $_} $self->{+MAX}, $ENV{T2_WORKFLOW_ASYNC}; + my $max = @max ? min(@max) : 3; + $self->{+MAX} = $max; + $self->{+SLOTS} = [] if $max; + + unless(defined($self->{+FILTER})) { + if (my $raw = $ENV{T2_WORKFLOW}) { + my ($file, $line, $name); + if ($raw =~ m/^(.*)\s+(\d+)$/) { + ($file, $line) = ($1, $2); + } + elsif($raw =~ m/^(\d+)$/) { + $line = $1; + } + else { + $name = $raw; + } + + $self->{+FILTER} = { + file => $file, + line => $line, + name => $name, + }; + } + } + + if (my $task = delete $self->{task}) { + $self->push_task($task); + } +} + +sub is_local { + my $self = shift; + return 0 unless $self->{+PID} == $$; + return 0 unless $self->{+TID} == get_tid(); + return 1; +} + +sub send_event { + my $self = shift; + my ($type, %params) = @_; + + my $class; + if ($type =~ m/\+(.*)$/) { + $class = $1; + } + else { + $class = "Test2::Event::$type"; + } + + my $hub = Test2::API::test2_stack()->top(); + + my $e = $class->new( + trace => Test2::Util::Trace->new( + frame => [caller(0)], + buffered => $hub->buffered, + nested => $hub->nested, + hid => $hub->hid, + huuid => $hub->uuid, + #cid => $self->{+CID}, + #uuid => $self->{+UUID}, + ), + + %params, + ); + + $hub->send($e); +} + +sub current_subtest { + my $self = shift; + my $stack = $self->{+STACK} or return undef; + + for my $state (reverse @$stack) { + next unless $state->{subtest}; + return $state->{subtest}; + } + + return undef; +} + +sub run { + my $self = shift; + + my $stack = $self->stack; + + my $c = 0; + while (@$stack) { + $self->cull; + + my $state = $stack->[-1]; + my $task = $state->{task}; + + unless($state->{started}++) { + my $skip = $task->skip; + + my $filter; + if (my $f = $self->{+FILTER}) { + my $in_var = grep { $_->{filter_satisfied} } @$stack; + + $filter = $task->filter($f) unless $in_var; + $state->{filter_satisfied} = 1 if $filter->{satisfied}; + } + + $skip ||= $filter->{skip} if $filter; + + if ($skip) { + $state->{ended}++; + $self->send_event( + 'Skip', + reason => $skip || $filter, + name => $task->name, + pass => 1, + effective_pass => 1, + ); + pop @$stack; + next; + } + + if ($task->flat) { + my $st = $self->current_subtest; + my $hub = $st ? $st->hub : Test2::API::test2_stack->top; + + $state->{todo} = Test2::Todo->new(reason => $task->todo, hub => $hub) + if $task->todo; + + $hub->send($_) for @{$task->events}; + } + else { + my $st = Test2::AsyncSubtest->new( + name => $task->name, + frame => $task->frame, + ); + $state->{subtest} = $st; + + $state->{todo} = Test2::Todo->new(reason => $task->todo, hub => $st->hub) + if $task->todo; + + for my $e (@{$task->events}) { + my $hub = $st->hub; + + $e->trace->{buffered} = $hub->buffered; + $e->trace->{nested} = $hub->nested; + $e->trace->{hid} = $hub->hid; + $e->trace->{huuid} = $hub->uuid; + + $hub->send($e); + } + + my $slot = $self->isolate($state); + + # if we forked/threaded then this state has ended here. + if (defined($slot)) { + push @{$self->{+SUBTESTS}} => [$st, $task] unless $st->finished; + $state->{subtest} = undef; + $state->{ended} = 1; + } + } + } + + if ($state->{ended}) { + $state->{todo}->end() if $state->{todo}; + $state->{subtest}->stop() if $state->{subtest}; + + return if $state->{in_thread}; + if(my $guard = delete $state->{in_fork}) { + $state->{subtest}->detach; + $guard->dismiss; + exit 0; + } + + pop @$stack; + next; + } + + if($state->{subtest} && !$state->{subtest_started}++) { + push @{$self->{+SUBTESTS}} => [$state->{subtest}, $task]; + $state->{subtest}->start(); + } + + if ($task->isa('Test2::Workflow::Task::Action')) { + $state->{PID} = $$; + my $ok = eval { $task->code->($self); 1 }; + + unless ($state->{PID} == $$) { + print STDERR "Task '" . $task->name . "' started in pid $state->{PID}, but ended in pid $$, did you forget to exit after forking?\n"; + exit 255; + } + + $task->exception($@) unless $ok; + $state->{ended} = 1; + + next; + } + + if (!$state->{stage} || $state->{stage} eq 'BEFORE') { + $state->{before} = (defined $state->{before}) ? $state->{before} : 0; + + if (my $add = $task->before->[$state->{before}++]) { + if ($add->around) { + $state->{PID} = $$; + my $ok = eval { $add->code->($self); 1 }; + my $err = $@; + my $complete = $state->{stage} && $state->{stage} eq 'AFTER'; + + unless ($state->{PID} == $$) { + print STDERR "Task '" . $task->name . "' started in pid $state->{PID}, but ended in pid $$, did you forget to exit after forking?\n"; + exit 255; + } + + unless($ok && $complete) { + $state->{ended} = 1; + $state->{stage} = 'AFTER'; + $task->exception($ok ? "'around' task failed to continue into the workflow chain.\n" : $err); + } + } + else { + $self->push_task($add); + } + } + else { + $state->{stage} = 'VARIANT'; + } + } + elsif ($state->{stage} eq 'VARIANT') { + if (my $v = $task->variant) { + $self->push_task($v); + } + $state->{stage} = 'PRIMARY'; + } + elsif ($state->{stage} eq 'PRIMARY') { + unless (defined $state->{order}) { + my $rand = defined($task->rand) ? $task->rand : $self->rand; + $state->{order} = [0 .. scalar(@{$task->primary}) - 1]; + @{$state->{order}} = shuffle(@{$state->{order}}) + if $rand; + } + my $num = shift @{$state->{order}}; + if (defined $num) { + $self->push_task($task->primary->[$num]); + } + else { + $state->{stage} = 'AFTER'; + } + } + elsif ($state->{stage} eq 'AFTER') { + $state->{after} = (defined $state->{after}) ? $state->{after} : 0; + if (my $add = $task->after->[$state->{after}++]) { + return if $add->around; + $self->push_task($add); + } + else { + $state->{ended} = 1; + } + } + } + + $self->finish; +} + +sub push_task { + my $self = shift; + my ($task) = @_; + + confess "No Task!" unless $task; + confess "Bad Task ($task)!" unless blessed($task) && $task->isa('Test2::Workflow::Task'); + + if ($task->isa('Test2::Workflow::Build')) { + confess "Can only push a Build instance when initializing the stack" + if @{$self->{+STACK}}; + $task = $task->compile(); + } + + push @{$self->{+STACK}} => { + task => $task, + name => $task->name, + }; +} + +sub add_mock { + my $self = shift; + my ($mock) = @_; + my $stack = $self->{+STACK}; + + confess "Nothing on the stack!" + unless $stack && @$stack; + + my ($state) = grep { !$_->{task}->scaffold} reverse @$stack; + push @{$state->{mocks}} => $mock; +} + +sub isolate { + my $self = shift; + my ($state) = @_; + + return if $state->{task}->skip; + + my $iso = $state->{task}->iso; + my $async = $state->{task}->async; + + # No need to isolate + return undef unless $iso || $async; + + # Cannot isolate + unless($self->{+MAX} && $self->is_local) { + # async does not NEED to be isolated + return undef unless $iso; + } + + # Wait for a slot, if max is set to 0 then we will not find a slot, instead + # we use '0'. We need to return a defined value to let the stack know that + # the task has ended. + my $slot = 0; + while($self->{+MAX} && $self->is_local) { + $self->cull; + for my $s (1 .. $self->{+MAX}) { + my $st = $self->{+SLOTS}->[$s]; + next if $st && !$st->finished; + $self->{+SLOTS}->[$s] = undef; + $slot = $s; + last; + } + last if $slot; + sleep(0.02); + } + + my $st = $state->{subtest} + or confess "Cannot isolate a task without a subtest"; + + if (!$self->no_fork) { + my $out = $st->fork; + if (blessed($out)) { + $state->{in_fork} = $out; + + # drop back out to complete the task. + return undef; + } + else { + $self->send_event( + 'Note', + message => "Forked PID $out to run: " . $state->{task}->name, + ); + $state->{pid} = $out; + } + } + elsif (!$self->no_threads) { + $state->{in_thread} = 1; + my $thr = $st->run_thread(\&run, $self); + $state->{thread} = $thr; + delete $state->{in_thread}; + $self->send_event( + 'Note', + message => "Started Thread-ID " . $thr->tid . " to run: " . $state->{task}->name, + ); + } + else { + $st->finish(skip => "No isolation method available"); + return 0; + } + + if($slot) { + $self->{+SLOTS}->[$slot] = $st; + } + else { + $st->finish; + } + + return $slot; +} + +sub cull { + my $self = shift; + + my $subtests = delete $self->{+SUBTESTS} || return; + my @new; + + # Cull subtests in reverse order, Nested subtests end before their parents. + for my $set (reverse @$subtests) { + my ($st, $task) = @$set; + next if $st->finished; + if (!$st->active && $st->ready) { + $st->finish(); + next; + } + + # Use unshift to preserve order. + unshift @new => $set; + } + + $self->{+SUBTESTS} = \@new; + + return; +} + +sub finish { + my $self = shift; + while(@{$self->{+SUBTESTS}}) { + $self->cull; + sleep(0.02) if @{$self->{+SUBTESTS}}; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Workflow::Runner - Runs the workflows. + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/lib/Test2/Workflow/Task.pm b/cpan/Test2-Suite/lib/Test2/Workflow/Task.pm new file mode 100644 index 000000000000..1d5f178d2ab5 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Workflow/Task.pm @@ -0,0 +1,182 @@ +package Test2::Workflow::Task; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Test2::API(); +use Test2::Event::Exception(); + +use List::Util qw/min max/; +use Scalar::Util qw/blessed/; +use Carp qw/croak/; +our @CARP_NOT = qw/Test2::Util::HashBase/; + +use base 'Test2::Workflow::BlockBase'; +use Test2::Util::HashBase qw/name flat async iso todo skip scaffold events is_root/; + +for my $attr (FLAT, ISO, ASYNC, TODO, SKIP, SCAFFOLD) { + my $old = __PACKAGE__->can("set_$attr"); + my $new = sub { + my $self = shift; + my $out = $self->$old(@_); + $self->verify_scaffold; + return $out; + }; + + no strict 'refs'; + no warnings 'redefine'; + *{"set_$attr"} = $new; +} + +sub init { + my $self = shift; + + $self->{+EVENTS} ||= []; + + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $self->SUPER::init(); + } + + $self->throw("the 'name' attribute is required") + unless $self->{+NAME}; + + $self->throw("the 'flat' attribute cannot be combined with 'iso' or 'async'") + if $self->{+FLAT} && ($self->{+ISO} || $self->{+ASYNC}); + + $self->set_subname($self->package . "::<$self->{+NAME}>"); + + $self->verify_scaffold; +} + +sub clone { + my $self = shift; + return bless {%$self}, blessed($self); +} + +sub verify_scaffold { + my $self = shift; + + return unless $self->{+SCAFFOLD}; + + croak "The 'flat' attribute must be true for scaffolding" + if defined($self->{+FLAT}) && !$self->{+FLAT}; + + $self->{+FLAT} = 1; + + for my $attr (ISO, ASYNC, TODO, SKIP) { + croak "The '$attr' attribute cannot be used on scaffolding" + if $self->{$attr}; + } +} + +sub exception { + my $self = shift; + my ($err) = @_; + + my $hub = Test2::API::test2_stack->top; + + my $trace = $self->trace($hub); + + $hub->send( + Test2::Event::Exception->new( + trace => $trace, + error => $err, + ), + ); +} + +sub filter { + my $self = shift; + my ($filter) = @_; + + return unless $filter; + return if $self->{+IS_ROOT}; + return if $self->{+SCAFFOLD}; + + if (my $name = $filter->{name}) { + my $ok = 0; + unless(ref($name)) { + $ok ||= $self->{+NAME} eq $name; + $ok ||= $self->subname eq $name; + } + if (ref($name) eq 'Regexp') { + $ok ||= $self->{+NAME} =~ $name; + $ok ||= $self->subname =~ $name; + } + elsif ($name =~ m{^/}) { + my $pattern = eval "qr$name" or die "'$name' does not appear to be a valid pattern"; + $ok ||= $self->{+NAME} =~ $pattern; + $ok ||= $self->subname =~ $pattern; + } + + return {skip => "Does not match name filter '$name'"} + unless $ok; + } + + if (my $file = $filter->{file}) { + return {skip => "Does not match file filter '$file'"} + unless $self->file eq $file; + } + + if (my $line = $filter->{line}) { + my $lines = $self->lines; + + return {skip => "Does not match line filter '$line' (no lines)"} + unless $lines && @$lines; + + my $min = min(@$lines); + my $max = max(@$lines); + + return {skip => "Does not match line filter '$min <= $line <= $max'"} + unless $min <= $line && $max >= $line; + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Workflow::Task - Encapsulation of a Task + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/lib/Test2/Workflow/Task/Action.pm b/cpan/Test2-Suite/lib/Test2/Workflow/Task/Action.pm new file mode 100644 index 000000000000..8f5f874c7418 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Workflow/Task/Action.pm @@ -0,0 +1,53 @@ +package Test2::Workflow::Task::Action; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use base 'Test2::Workflow::Task'; +use Test2::Util::HashBase qw/around/; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Workflow::Task::Action - Encapsulation of an action. + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/lib/Test2/Workflow/Task/Group.pm b/cpan/Test2-Suite/lib/Test2/Workflow/Task/Group.pm new file mode 100644 index 000000000000..cf424a6fa986 --- /dev/null +++ b/cpan/Test2-Suite/lib/Test2/Workflow/Task/Group.pm @@ -0,0 +1,111 @@ +package Test2::Workflow::Task::Group; +use strict; +use warnings; + +our $VERSION = '0.000156'; + +use Carp qw/croak/; + +use Test2::Workflow::Task::Action; + +use base 'Test2::Workflow::Task'; +use Test2::Util::HashBase qw/before after primary rand variant/; + +sub init { + my $self = shift; + + if (my $take = delete $self->{take}) { + $self->{$_} = delete $take->{$_} for ISO, ASYNC, TODO, SKIP; + $self->{$_} = $take->{$_} for FLAT, SCAFFOLD, NAME, CODE, FRAME; + $take->{+FLAT} = 1; + $take->{+SCAFFOLD} = 1; + } + + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $self->SUPER::init(); + } + + $self->{+BEFORE} ||= []; + $self->{+AFTER} ||= []; + $self->{+PRIMARY} ||= []; +} + +sub filter { + my $self = shift; + my ($filter) = @_; + + return if $self->{+IS_ROOT}; + + my $result = $self->SUPER::filter($filter); + + my $child_ok = 0; + for my $c (@{$self->{+PRIMARY}}) { + next if $c->{+SCAFFOLD}; + # A child matches the filter, so we should not be filtered, but also + # should not satisfy the filter. + my $res = $c->filter($filter); + + # A child satisfies the filter + $child_ok++ if !$res || $res->{satisfied}; + last if $child_ok; + } + + # If the filter says we are ok + unless($result) { + # If we are a variant then allow everything under us to be run + return {satisfied => 1} if $self->{+VARIANT} || !$child_ok; + + # Normal group + return; + } + + return if $child_ok; + + return $result; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Workflow::Task::Group - Encapsulation of a group (describe). + +=head1 SOURCE + +The source code repository for Test2-Workflow 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 2018 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + diff --git a/cpan/Test2-Suite/t/acceptance/OO.t b/cpan/Test2-Suite/t/acceptance/OO.t new file mode 100644 index 000000000000..624eaafb4766 --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/OO.t @@ -0,0 +1,124 @@ +use Test2::Bundle::Extended; +use Test2::AsyncSubtest; +use Test2::Tools::Compare qw{ array event field }; +use Test2::IPC; +use Test2::Util qw/CAN_REALLY_FORK CAN_THREAD get_tid/; + +sub DO_THREADS { + return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; + return Test2::AsyncSubtest->CAN_REALLY_THREAD; +} + +my $wrap = Test2::AsyncSubtest->new(name => 'wrap'); +$wrap->start; + +my $t1 = Test2::AsyncSubtest->new(name => 't1'); +my $t2 = Test2::AsyncSubtest->new(name => 't2'); + +$wrap->stop; + +$_->run(sub { + ok(1, "not concurrent A"); +}) for $t1, $t2; + +ok(1, "Something else"); + +if (CAN_REALLY_FORK) { + my @pids; + + $_->run(sub { + my $id = $_->cleave; + my $pid = fork; + die "Failed to fork!" unless defined $pid; + if ($pid) { + push @pids => $pid; + return; + } + + my $ok = eval { + $_->attach($id); + + ok(1, "from proc $$"); + + $_->detach(); + + 1 + }; + exit 0 if $ok; + warn $@; + exit 255; + }) for $t1, $t2; + + waitpid($_, 0) for @pids; +} + +ok(1, "Something else"); + +if (DO_THREADS()) { + require threads; + my @threads; + + $_->run(sub { + my $id = $_->cleave; + push @threads => threads->create(sub { + $_->attach($id); + ok(1, "from thread " . get_tid); + $_->detach(); + }); + }) for $t1, $t2; + + $_->join for @threads; +} + +$_->run(sub { + ok(1, "not concurrent B"); +}) for $t1, $t2; + +ok(1, "Something else"); + +ok($wrap->pending, "Pending stuff"); + +$_->finish for $t1, $t2; + +ok(!$wrap->pending, "Ready now"); +$wrap->finish; + +is( + intercept { + my $t = Test2::AsyncSubtest->new(name => 'will die'); + $t->run(sub { die "kaboom!\n" }); + $t->finish; + }, + array { + event Subtest => sub { + field name => 'will die'; + field subevents => array { + event Exception => sub { + field error => "kaboom!\n"; + }; + event Plan => sub { + field max => 0; + }; + }; + }; + event Diag => sub { + field message => match qr/\QFailed test 'will die'/; + }; + end(); + }, + 'Subtest that dies not add a diagnostic about a bad plan' +); + +my $sta = Test2::AsyncSubtest->new(name => 'collapse: empty'); +my $stb = Test2::AsyncSubtest->new(name => 'collapse: note only'); +my $stc = Test2::AsyncSubtest->new(name => 'collapse: full'); + +$stb->run(sub { note "inside" }); +$stc->run(sub { ok(1, "test") }); + +$sta->finish(collapse => 1); +$stb->finish(collapse => 1); +$stc->finish(collapse => 1); + + +done_testing; diff --git a/cpan/Test2-Suite/t/acceptance/Tools.t b/cpan/Test2-Suite/t/acceptance/Tools.t new file mode 100644 index 000000000000..da3e621aa165 --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/Tools.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +use Test2::Util qw/get_tid CAN_REALLY_FORK/; +use Test2::Bundle::Extended; +use Test2::Tools::AsyncSubtest; + +imported_ok qw/async_subtest fork_subtest thread_subtest/; + +sub DO_THREADS { + return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; + return Test2::AsyncSubtest->CAN_REALLY_THREAD; +} + +my $ast = async_subtest foo => sub { + ok(1, "Simple"); +}; +$ast->finish; + +if (CAN_REALLY_FORK) { + my $f_ast = fork_subtest foo => sub { + ok(1, "forked $$"); + + my $f2_ast = fork_subtest bar => sub { + ok(1, "forked again $$"); + }; + + $f2_ast->finish; + }; + + $f_ast->finish; +} + +if (DO_THREADS()) { + my $t_ast = thread_subtest foo => sub { + ok(1, "threaded " . get_tid); + + my $t2_ast = thread_subtest bar => sub { + ok(1, "threaded again " . get_tid); + }; + + $t2_ast->finish; + }; + + $t_ast->finish; +} + +done_testing; diff --git a/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance.t b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance.t new file mode 100644 index 000000000000..253e0f3bee2e --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance.t @@ -0,0 +1,829 @@ +use strict; +use warnings; +use Test2::Bundle::Extended; +use Test2::Tools::Spec qw/:DEFAULT include_workflow/; + +use Test2::Workflow::Runner; + +use Test2::API qw/intercept/; +use Test2::Util qw/get_tid/; + +my $B = describe foo => sub { + before_all start => sub { ok(1, 'start') }; + + around_all al => sub { + my $cont = shift; + ok(1, 'al start'); + $cont->(); + ok(1, 'al end'); + }; + + after_all end => sub { ok(1, 'end') }; + + before_each bef => sub { ok(1, 'a') }; + + around_each arr => sub { + my $cont = shift; + ok(1, 'ar start'); + $cont->(); + ok(1, 'ar end'); + }; + + after_each aft => sub { ok(1, 'z') }; + + case c1 => sub { ok(1, 'in c1') }; + case c2 => sub { ok(1, 'in c2') }; + + before_case bc => sub { ok(1, 'in bc') }; + around_case arc => sub { + my $cont = shift; + ok(1, 'arc start'); + $cont->(); + ok(1, 'arc end'); + }; + after_case ac => sub { ok(1, 'in ac') }; + + tests bar => {iso => 1}, sub { + ok(1, "inside bar pid $$ - tid " . get_tid()); + }; + + tests baz => sub { + ok(1, "inside baz pid $$ - tid " . get_tid()); + }; + + tests uhg => sub { + my $todo = todo "foo todo"; + ok(0, 'xxx'); + }; + + tests bug => {todo => 'a bug'}, sub { + ok(0, 'fail'); + }; + + tests broken => {skip => 'will break things'}, sub { + warn "\n\n**** You should not see this! ****\n\n"; + print STDERR Carp::longmess('here'); + print "not ok - You should not see this\n"; + exit 255; + }; + + describe nested => {iso => 1}, sub { + before_each n1_be => sub { ok(1, 'nested before') }; + after_each n1_ae => sub { ok(1, 'nested after') }; + + tests n1 => sub { ok(1, 'nested 1') }; + tests n2 => sub { ok(1, 'nested 2') }; + }; +}; + +my $r1 = Test2::Workflow::Runner->new(task => $B, no_threads => 1); +$r1->run; + +my $r2 = Test2::Workflow::Runner->new(task => $B, no_fork => 1); +$r2->run; + +my $r3 = Test2::Workflow::Runner->new(task => $B, no_fork => 1, no_threads => 1); +$r3->run; + +tests on_root => sub { ok(1, "in root") }; + +{ + package Foo::Bar; + + sub foo { 'xxx' } +} + +describe in_root => {flat => 1}, sub { + is(Foo::Bar->foo, 'xxx', "not mocked"); + + mock 'Foo::Bar' => ( + override => [ + foo => sub { 'foo' }, + ], + ); + + is(Foo::Bar->foo, 'foo', "mocked"); + + tests on_root_a => sub { + ok(1, "in root"); + is(Foo::Bar->foo, 'foo', "mocked"); + }; + + describe 'iso-in-iso' => {iso => 1}, sub { + tests on_root_b => {iso => 1}, sub { ok(1, "in root") }; + tests on_root_c => {iso => 1}, sub { ok(1, "in root") }; + tests on_root_d => {iso => 1}, sub { ok(1, "in root") }; + }; + + my $B = describe included => sub { + tests inside => sub { ok(1, "xxx") }; + }; + include_workflow($B); +}; + +is(Foo::Bar->foo, 'xxx', "not mocked"); + +describe todo_desc => {todo => 'cause'}, sub { + ok(0, "not ready"); + + tests foo => sub { + ok(0, "not ready nested"); + } +}; + +describe skip_desc => {skip => 'cause'}, sub { + print STDERR "Should not see this!\n"; + print "not ok - You should not see this\n"; + exit 255; +}; + +eval { + describe dies => sub { + ok(1, 'xxx'); + ok(1, 'xxx'); + die "xxx"; + }; + 1; +}; +like( + $@, + check_set( + qr/^Exception in build 'dies' with 2 unseen event\(s\)\.$/m, + qr{^xxx at .*Acceptance\.t line \d+\.$}m, + qr/^Overview of unseen events:/m, + qr/^ Test2::Event::Ok at .*Acceptance\.t line \d+$/m, + qr/^ Test2::Event::Ok at .*Acceptance\.t line \d+/m, + ), + "Error is as expected" +); + +my $events = intercept { + my $r = Test2::Workflow::Runner->new(task => $B, no_fork => 1, no_threads => 1, rand => 0); + $r->run; +}; + +is( + $events, + array { + event Subtest => sub { + call name => 'foo'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 77; + + call subevents => array { + event Ok => sub { + call name => 'start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 12; + }; + + event Ok => sub { + call name => 'al start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 16; + }; + + event Subtest => sub { + call name => 'c1'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 34; + + call subevents => array { + event Ok => sub { + call name => 'in bc'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 37; + }; + + event Ok => sub { + call name => 'arc start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 40; + }; + + event Ok => sub { + call name => 'in c1'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 34; + }; + + event Skip => sub { + call name => 'bar'; + call pass => 1; + call effective_pass => 1; + call reason => 'No isolation method available'; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 48; + }; + + event Subtest => sub { + call name => 'baz'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 52; + + call subevents => array { + event Ok => sub { + call name => 'a'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 23; + }; + + event Ok => sub { + call name => 'ar start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 27; + }; + + event Ok => sub { + call name => match qr/inside baz pid/; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 51; + }; + + event Ok => sub { + call name => 'ar end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 29; + }; + + event Ok => sub { + call name => 'z'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 32; + }; + + event Plan => sub { + call max => 5; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 52; + }; + end(); + }; + }; + + event Subtest => sub { + call name => 'uhg'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 57; + + call subevents => array { + event Ok => sub { + call name => 'a'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 23; + }; + + event Ok => sub { + call name => 'ar start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 27; + }; + + event Ok => sub { + call name => 'xxx'; + call pass => 0; + call effective_pass => 1; + call todo => 'foo todo'; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 56; + }; + + event Note => sub { + call message => match qr{^\n?Failed test}; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 56; + }; + + event Ok => sub { + call name => 'ar end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 29; + }; + + event Ok => sub { + call name => 'z'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 32; + }; + + event Plan => sub { + call max => 5; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 57; + }; + end(); + }; + }; + + event Subtest => sub { + call name => 'bug'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 61; + + call subevents => array { + event Ok => sub { + call name => 'a'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 23; + }; + + event Ok => sub { + call name => 'ar start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 27; + }; + + event Ok => sub { + call name => 'fail'; + call pass => 0; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 60; + }; + + event Note => sub { + call message => match qr{^\n?Failed test}; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 60; + }; + + event Ok => sub { + call name => 'ar end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 29; + }; + + event Ok => sub { + call name => 'z'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 32; + }; + + event Plan => sub { + call max => 5; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 61; + }; + end(); + }; + }; + + event Skip => sub { + call name => 'broken'; + call pass => 1; + call effective_pass => 1; + call reason => 'will break things'; + + prop file => match qr{\QRunner.pm\E$}; + }; + + event Skip => sub { + call name => 'nested'; + call pass => 1; + call effective_pass => 1; + call reason => 'No isolation method available'; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 76; + }; + + event Ok => sub { + call name => 'arc end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 42; + }; + + event Ok => sub { + call name => 'in ac'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 44; + }; + + event Plan => sub { + call max => 11; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 34; + }; + end(); + }; + }; + + event Subtest => sub { + call name => 'c2'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 35; + + call subevents => array { + event Ok => sub { + call name => 'in bc'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 37; + }; + + event Ok => sub { + call name => 'arc start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 40; + }; + + event Ok => sub { + call name => 'in c2'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 35; + }; + + event Skip => sub { + call name => 'bar'; + call pass => 1; + call effective_pass => 1; + call reason => 'No isolation method available'; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 48; + }; + + event Subtest => sub { + call name => 'baz'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 52; + + call subevents => array { + event Ok => sub { + call name => 'a'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 23; + }; + + event Ok => sub { + call name => 'ar start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 27; + }; + + event Ok => sub { + call name => match qr/inside baz pid/; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 51; + }; + + event Ok => sub { + call name => 'ar end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 29; + }; + + event Ok => sub { + call name => 'z'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 32; + }; + + event Plan => sub { + call max => 5; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 52; + }; + end(); + }; + }; + + event Subtest => sub { + call name => 'uhg'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 57; + + call subevents => array { + event Ok => sub { + call name => 'a'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 23; + }; + + event Ok => sub { + call name => 'ar start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 27; + }; + + event Ok => sub { + call name => 'xxx'; + call pass => 0; + call effective_pass => 1; + call todo => 'foo todo'; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 56; + }; + + event Note => sub { + call message => match qr{^\n?Failed test}; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 56; + }; + + event Ok => sub { + call name => 'ar end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 29; + }; + + event Ok => sub { + call name => 'z'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 32; + }; + + event Plan => sub { + call max => 5; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 57; + }; + end(); + }; + }; + + event Subtest => sub { + call name => 'bug'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 61; + + call subevents => array { + event Ok => sub { + call name => 'a'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 23; + }; + + event Ok => sub { + call name => 'ar start'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 27; + }; + + event Ok => sub { + call name => 'fail'; + call pass => 0; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 60; + }; + + event Note => sub { + call message => match qr{^\n?Failed test}; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 60; + }; + + event Ok => sub { + call name => 'ar end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 29; + }; + + event Ok => sub { + call name => 'z'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 32; + }; + + event Plan => sub { + call max => 5; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 61; + }; + end(); + }; + }; + + event Skip => sub { + call name => 'broken'; + call pass => 1; + call effective_pass => 1; + call reason => 'will break things'; + + prop file => match qr{\QRunner.pm\E$}; + }; + + event Skip => sub { + call name => 'nested'; + call pass => 1; + call effective_pass => 1; + call reason => 'No isolation method available'; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 76; + }; + + event Ok => sub { + call name => 'arc end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 42; + }; + + event Ok => sub { + call name => 'in ac'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 44; + }; + + event Plan => sub { + call max => 11; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 35; + }; + end(); + }; + }; + + event Ok => sub { + call name => 'al end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 18; + }; + + event Ok => sub { + call name => 'end'; + call pass => 1; + call effective_pass => 1; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 21; + }; + + event Plan => sub { + call max => 6; + + prop file => match qr{\QAcceptance.t\E$}; + prop line => 77; + }; + end(); + }; + }; + end(); + }, + "Events look correct" +); + +done_testing; + +1; diff --git a/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance2.t b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance2.t new file mode 100644 index 000000000000..332d122352fc --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance2.t @@ -0,0 +1,16 @@ +use strict; +use warnings; +use Test2::Bundle::Extended; +use Test2::Tools::Spec; + +describe outer => sub { + tests foo => sub { ok(1, 'foo') }; + + describe inner => sub { + tests bar => sub { ok(1, 'bar') }; + }; +}; + +tests foo => sub { ok(1, 'foo') }; + +done_testing; diff --git a/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance3.t b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance3.t new file mode 100644 index 000000000000..cd6c1277970b --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance3.t @@ -0,0 +1,9 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec; + +# This is a test that things are ok if you do not use the spec after loading +# it. + +ok(1, "blah"); + +done_testing; diff --git a/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance4.t b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance4.t new file mode 100644 index 000000000000..f6b20a969618 --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance4.t @@ -0,0 +1,14 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec; + +use Test2::API qw/intercept/; + +my $unit = tests simple => sub { + ok(1, "inside simple"); +}; + +my $runner = Test2::Workflow::Runner->new; +$runner->push_task($unit); +$runner->run; + +done_testing; diff --git a/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance5.t b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance5.t new file mode 100644 index 000000000000..cbcb96955411 --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/Workflow-Acceptance5.t @@ -0,0 +1,43 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec qw/:ALL/; +use Test2::Util qw/get_tid/; + +sub get_ids { + return { + pid => $$, + tid => get_tid(), + }; +} + +my $orig = get_ids(); + +spec_defaults case => (iso => 1, async => 1); +spec_defaults tests => (iso => 1, async => 1); + +tests outside => sub { + isnt(get_ids(), $orig, "In child (lexial)"); +}; + +describe wrapper => sub { + case foo => sub { + isnt(get_ids(), $orig, "In child (inherited)") + }; + + case 'bar', {iso => 0, async => 0} => sub { + is(get_ids(), $orig, "In orig (overriden)") + }; + + tests a => sub { ok(1, 'stub') }; + tests b => sub { ok(1, 'stub') }; + + my $x = describe nested => sub { + tests nested_t => sub { ok(0, 'Should not see this') }; + }; + + tests nested => sub { + ok(!$x->primary->[0]->iso, "Did not inherit when captured"); + ok(!$x->primary->[0]->async, "Did not inherit when captured"); + }; +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/acceptance/skip.t b/cpan/Test2-Suite/t/acceptance/skip.t new file mode 100644 index 000000000000..80d4c895d116 --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/skip.t @@ -0,0 +1,151 @@ +use Test2::Bundle::Extended; +use Test2::AsyncSubtest; +use Test2::Tools::AsyncSubtest; +use Test2::Tools::Compare qw{ array event call T }; +use Test2::IPC; +use Test2::Util qw/CAN_REALLY_FORK/; +use Test2::API qw/context context_do intercept/; + +sub DO_THREADS { + return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; + return Test2::AsyncSubtest->CAN_REALLY_THREAD; +} + +skip_all 'These tests require forking or threading' + unless CAN_REALLY_FORK || DO_THREADS(); + +subtest( + 'fork tests', + sub { + run_tests('fork'); + stress_tests('fork'); + } +) if CAN_REALLY_FORK; + +subtest( + 'thread tests', + sub { + run_tests('thread'); + stress_tests('thread'); + } +) if DO_THREADS(); + +done_testing; + +sub run_tests { + my $type = shift; + + my $st_sub = $type eq 'fork' ? \&fork_subtest : \&thread_subtest; + + is( + intercept { + $st_sub->( + '$ctx->plan(0, SKIP)', + sub { + skip_all 'because'; + ok(0, "Should not see"); + } + )->finish; + }, + array { + event Subtest => sub { + call name => '$ctx->plan(0, SKIP)'; + call pass => T(); + call subevents => array { + event '+Test2::AsyncSubtest::Event::Attach'; + event Plan => sub { + call directive => 'SKIP'; + call reason => 'because'; + }; + event '+Test2::AsyncSubtest::Event::Detach'; + end(); + }; + }; + end(); + }, + qq[${type}_subtest with skip_all] + ); + + is( + intercept { + $st_sub->( + 'skip_all', + { manual_skip_all => 1 }, + sub { + skip_all 'because'; + note "Post skip"; + return; + } + )->finish; + }, + array { + event Subtest => sub { + call name => 'skip_all'; + call pass => T(); + call subevents => array { + event '+Test2::AsyncSubtest::Event::Attach'; + event Plan => sub { + call directive => 'SKIP'; + call reason => 'because'; + }; + event Note => { message => 'Post skip' }; + event '+Test2::AsyncSubtest::Event::Detach'; + end(); + }; + }; + end(); + }, + qq[${type}_subtest with skip_all and manual skip return}] + ); + + my $method = 'run_' . $type; + is( + intercept { + my $at = Test2::AsyncSubtest->new(name => '$ctx->plan(0, SKIP)'); + $at->$method( + sub { + skip_all 'because'; + ok(0, "should not see"); + } + ); + $at->finish; + }, + array { + event Subtest => sub { + call name => '$ctx->plan(0, SKIP)'; + call pass => T(); + call subevents => array { + event '+Test2::AsyncSubtest::Event::Attach'; + event Plan => sub { + call directive => 'SKIP'; + call reason => 'because'; + }; + event '+Test2::AsyncSubtest::Event::Detach'; + end(); + }; + }; + end(); + }, + qq[\$subtest->$method with skip_all] + ); +} + +sub stress_tests { + my $type = shift; + + my $st_sub = $type eq 'fork' ? \&fork_subtest : \&thread_subtest; + + for my $i (2 .. 5) { + my @st; + for my $j (1 .. $i) { + push @st, $st_sub->( + "skip all $i - $j", + sub { + skip_all 'because'; + ok(0, "should not see"); + } + ); + } + $_->finish for @st; + } +} diff --git a/cpan/Test2-Suite/t/acceptance/spec.t b/cpan/Test2-Suite/t/acceptance/spec.t new file mode 100644 index 000000000000..b9746e2b9e19 --- /dev/null +++ b/cpan/Test2-Suite/t/acceptance/spec.t @@ -0,0 +1,22 @@ +use Test2::V0 -target => 'Test2::Tools::Spec'; +use Test2::Tools::Spec; + +tests foo => sub { + ok(1, "pass"); +}; + +describe nested => sub { + my $x = 0; + + before_all set_x => sub { $x = 100 }; + + tests a => sub { + is($x, 100, "x was set (A)"); + }; + + tests b => sub { + is($x, 100, "x was set (B)"); + }; +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/behavior/Mocking.t b/cpan/Test2-Suite/t/behavior/Mocking.t new file mode 100644 index 000000000000..1b75344ba9bb --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/Mocking.t @@ -0,0 +1,45 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow'; +use Test2::Tools::Spec; + +describe mock_spec => sub { + mock Fake1 => ( add => [ check => sub { 1 } ] ); + + before_all ba => sub { mock Fake2 => ( add => [ check => sub { 2 } ])}; + before_each be => sub { mock Fake3 => ( add => [ check => sub { 3 } ])}; + + is( Fake1->check, 1, "mock applies to describe block"); + + around_each ae => sub { + my $inner = shift; + mock Fake4 => ( add => [check => sub { 4 } ]); + $inner->(); + }; + + tests the_test => sub { + mock Fake5 => ( add => [check => sub { 5 } ]); + + is( Fake1->check, 1, "mock 1"); + is( Fake2->check, 2, "mock 2"); + is( Fake3->check, 3, "mock 3"); + is( Fake4->check, 4, "mock 4"); + is( Fake5->check, 5, "mock 5"); + }; + + describe nested => sub { + tests inner => sub { + is( Fake1->check, 1, "mock 1"); + is( Fake2->check, 2, "mock 2"); + is( Fake3->check, 3, "mock 3"); + is( Fake4->check, 4, "mock 4"); + ok(!Fake5->can('check'), "mock 5 did not leak"); + }; + }; +}; + +tests post => sub { + ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; +}; + +ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; + +done_testing; diff --git a/cpan/Test2-Suite/t/behavior/async_trace.t b/cpan/Test2-Suite/t/behavior/async_trace.t new file mode 100644 index 000000000000..716d3e1f6c6c --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/async_trace.t @@ -0,0 +1,55 @@ +use Test2::Tools::Tiny qw/ok done_testing tests/; +use Test2::Tools::AsyncSubtest; +use Test2::API qw/intercept test2_add_uuid_via/; + +our %CNT; +test2_add_uuid_via(sub { + my $type = shift; + $CNT{$type} ||= 1; + $type . '-' . $CNT{$type}++; +}); + +my $events = intercept { + local %CNT = (); + tests foo => sub { + ok(1, "pass"); + }; + + local %CNT = (); + my $ast = async_subtest foo => sub { + ok(1, "pass"); + }; + $ast->finish; +}; + +tests regular => sub { + ok($events->[0]->subtest_uuid, "subtest got a subtest uuid"); + + ok($events->[0]->trace->{cid}, "subtest trace got a cid"); + ok($events->[0]->trace->{hid}, "subtest trace got a hid"); + ok($events->[0]->trace->{uuid}, "subtest trace got a uuid"); + ok($events->[0]->trace->{huuid}, "subtest trace got a huuid"); + + ok($events->[0]->subevents->[-1]->trace->{cid}, "subtest plan trace got a cid"); + ok($events->[0]->subevents->[-1]->trace->{hid}, "subtest plan trace got a hid"); + ok($events->[0]->subevents->[-1]->trace->{uuid}, "subtest plan trace got a uuid"); + ok($events->[0]->subevents->[-1]->trace->{huuid}, "subtest plan trace got a huuid"); +}; + +tests async => sub { + ok($events->[1]->subtest_uuid, "async subtest got a subtest uuid"); + + ok($events->[1]->trace->{cid}, "async subtest trace got a cid"); + ok($events->[1]->trace->{hid}, "async subtest trace got a hid"); + ok($events->[1]->trace->{uuid}, "async subtest trace got a uuid"); + ok($events->[1]->trace->{huuid}, "async subtest trace got a huuid"); + + ok($events->[1]->subevents->[-1]->trace->{cid}, "async subtest plan trace got a cid"); + ok($events->[1]->subevents->[-1]->trace->{hid}, "async subtest plan trace got a hid"); + ok($events->[1]->subevents->[-1]->trace->{uuid}, "async subtest plan trace got a uuid"); + ok($events->[1]->subevents->[-1]->trace->{huuid}, "async subtest plan trace got a huuid"); +}; + +done_testing; + +__END__ diff --git a/cpan/Test2-Suite/t/behavior/filtering.t b/cpan/Test2-Suite/t/behavior/filtering.t new file mode 100644 index 000000000000..a33ac092ba84 --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/filtering.t @@ -0,0 +1,616 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec -rand => 0; +use Test2::Workflow::Runner; + +my %LINES; + +sub example { + my $unit = describe root => {flat => 1}, sub { + before_all 'root_before_all' => sub { note "root_before_all" }; + after_all 'root_after_all' => sub { note 'root_after_all' }; + before_each 'root_before_each' => sub { note 'root_before_each' }; + after_each 'root_after_each' => sub { note 'root_after_each' }; + + around_all 'root_around_all' => sub { + note 'root_around_all_prefix'; + $_[0]->(); + note 'root_around_all_postfix'; + }; + + around_each 'root_around_each' => sub { + note 'root_around_each_prefix'; + $_[0]->(); + note 'root_around_each_postfix'; + }; + + case root_x => sub { note 'root case x' }; BEGIN { $LINES{root_x} = __LINE__ } + case root_y => sub { note 'root case y' }; BEGIN { $LINES{root_y} = __LINE__ } + + tests 'root_a' => sub { ok(1, 'root_a') }; BEGIN { $LINES{root_a} = __LINE__ } + tests 'root_b' => sub { ok(1, 'root_b') }; BEGIN { $LINES{root_b} = __LINE__ } + + tests 'root_long' => sub { + ok(1, 'root_long_1'); + + BEGIN { $LINES{root_long} = __LINE__ } + # Intentional space + + ok(1, 'root_long_2'); + }; + + tests dup_name => sub { ok(1, 'dup_name') }; + + describe nested => sub { + before_all 'nested_before_all' => sub { note "nested_before_all" }; + after_all 'nested_after_all' => sub { note 'nested_after_all' }; + before_each 'nested_before_each' => sub { note 'nested_before_each' }; + after_each 'nested_after_each' => sub { note 'nested_after_each' }; + + around_all 'nested_around_all' => sub { + note 'nested_around_all_prefix'; + $_[0]->(); + note 'nested_around_all_postfix'; + }; + + around_each 'nested_around_each' => sub { + note 'nested_around_each_prefix'; + $_[0]->(); + note 'nested_around_each_postfix'; + }; + + BEGIN { $LINES{nested} = __LINE__ } + + case nested_x => sub { note 'nested case x' }; BEGIN { $LINES{nested_x} = __LINE__ } + case nested_y => sub { note 'nested case y' }; BEGIN { $LINES{nested_y} = __LINE__ } + + tests 'nested_a' => sub { ok(1, 'nested_a') }; BEGIN { $LINES{nested_a} = __LINE__ } + tests 'nested_b' => sub { ok(1, 'nested_b') }; BEGIN { $LINES{nested_b} = __LINE__ } + + tests 'nested_long' => sub { + ok(1, 'nested_long_1'); + + BEGIN { $LINES{nested_long} = __LINE__ } + # Intentional space + + ok(1, 'nested_long_2'); + }; + + tests dup_name => sub { ok(1, 'dup_name') }; + }; + }; + return $unit; +}; + +describe root_test => sub { + my $filter; + my $type; + case line => {flat => 1}, sub { $type = 'line'; $filter = {line => $LINES{root_long}} }; + case name => {flat => 1}, sub { $type = 'name'; $filter = {name => 'root_long'} }; + + tests root => {flat => 1}, sub { + my $unit = example(); + + my $events = intercept { + Test2::Workflow::Runner->new( + rand => 0, + task => $unit, + filter => $filter + )->run(); + }; + + is( + $events, + array { + event Note => { message => 'root_before_all' }; + event Note => { message => 'root_around_all_prefix' }; + + event Subtest => sub { + call name => "root_$_"; + call subevents => array { + event Note => { message => "root case $_" }; + + event Skip => {}; + event Skip => {}; + + event Subtest => sub { + call name => 'root_long'; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + + event Ok => { name => 'root_long_1' }; + event Ok => { name => 'root_long_2' }; + + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + event Plan => { max => 2 }; + }; + }; + + event Skip => {}; + event Skip => {}; + + event Plan => { max => 5 }; + }; + } for qw/x y/; + + event Note => { message => 'root_after_all' }; + event Note => { message => 'root_around_all_postfix' }; + }, + "Got only the events that match the $type filter" + ); + }; +}; + +describe nested_test => sub { + my $filter; + my $type; + case line => {flat => 1}, sub { $type = 'line'; $filter = {line => $LINES{nested_long}} }; + case name => {flat => 1}, sub { $type = 'name'; $filter = {name => 'nested_long'} }; + + tests nested => {flat => 1}, sub { + my $unit = example(); + + my $events = intercept { + Test2::Workflow::Runner->new( + rand => 0, + task => $unit, + filter => $filter + )->run(); + }; + + is( + $events, + array { + event Note => { message => 'root_before_all' }; + event Note => { message => 'root_around_all_prefix' }; + + event Subtest => sub { + call name => "root_$_"; + call subevents => array { + event Note => { message => "root case $_" }; + + event Skip => {}; + event Skip => {}; + event Skip => {}; + event Skip => {}; + + event Subtest => sub { + call name => 'nested'; + call subevents => array { + event Note => { message => 'nested_before_all' }; + event Note => { message => 'nested_around_all_prefix' }; + + event Subtest => sub { + call name => "nested_$_"; + call subevents => array { + event Note => { message => "nested case $_" }; + + event Skip => {}; + event Skip => {}; + + event Subtest => sub { + call name => 'nested_long'; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + event Note => { message => 'nested_before_each' }; + event Note => { message => 'nested_around_each_prefix' }; + + event Ok => { name => 'nested_long_1' }; + event Ok => { name => 'nested_long_2' }; + + event Note => { message => 'nested_after_each' }; + event Note => { message => 'nested_around_each_postfix' }; + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + + event Plan => { max => 2 }; + }; + }; + + event Skip => {}; + + event Plan => { max => 4 }; + }; + } for qw/x y/; + + event Note => { message => 'nested_after_all' }; + event Note => { message => 'nested_around_all_postfix' }; + + event Plan => { max => 2 }; + }; + }; + + event Plan => { max => 5 }; + }; + } for qw/x y/; + + event Note => { message => 'root_after_all' }; + event Note => { message => 'root_around_all_postfix' }; + }, + "Got only the events that match the $type filter" + ); + }; +}; + +describe group => sub { + my $filter; + my $type; + case line => {flat => 1}, sub { $type = 'line'; $filter = {line => $LINES{nested}} }; + case name => {flat => 1}, sub { $type = 'name'; $filter = {name => 'nested'} }; + + tests nested => {flat => 1}, sub { + my $unit = example(); + + my $events = intercept { + Test2::Workflow::Runner->new( + rand => 0, + task => $unit, + filter => $filter + )->run(); + }; + + is( + $events, + array { + event Note => { message => 'root_before_all' }; + event Note => { message => 'root_around_all_prefix' }; + + event Subtest => sub { + call name => "root_$_"; + call subevents => array { + event Note => { message => "root case $_" }; + + event Skip => {}; + event Skip => {}; + event Skip => {}; + event Skip => {}; + + event Subtest => sub { + call name => 'nested'; + call subevents => array { + event Note => { message => 'nested_before_all' }; + event Note => { message => 'nested_around_all_prefix' }; + + event Subtest => sub { + call name => "nested_$_"; + call subevents => array { + event Note => { message => "nested case $_" }; + + event Subtest => sub { + call name => $_; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + event Note => { message => 'nested_before_each' }; + event Note => { message => 'nested_around_each_prefix' }; + + if ($_ eq 'nested_long') { + event Ok => { name => 'nested_long_1' }; + event Ok => { name => 'nested_long_2' }; + } + else { + event Ok => { name => $_ }; + } + + event Note => { message => 'nested_after_each' }; + event Note => { message => 'nested_around_each_postfix' }; + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + + event Plan => { max => T() }; + }; + } for qw/nested_a nested_b nested_long dup_name/; + + event Plan => { max => 4 }; + }; + } for qw/x y/; + + event Note => { message => 'nested_after_all' }; + event Note => { message => 'nested_around_all_postfix' }; + + event Plan => { max => 2 }; + }; + }; + + event Plan => { max => 5 }; + }; + } for qw/x y/; + + event Note => { message => 'root_after_all' }; + event Note => { message => 'root_around_all_postfix' }; + }, + "Got only the events that match the $type filter" + ); + }; +}; + +tests dup_name => sub { + my $unit = example(); + + my $events = intercept { + Test2::Workflow::Runner->new( + rand => 0, + task => $unit, + filter => {name => 'dup_name'} + )->run(); + }; + + is( + $events, + array { + event Note => { message => 'root_before_all' }; + event Note => { message => 'root_around_all_prefix' }; + + event Subtest => sub { + call name => "root_$_"; + call subevents => array { + event Note => { message => "root case $_" }; + + event Skip => {}; + event Skip => {}; + event Skip => {}; + + event Subtest => sub { + call name => 'dup_name'; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + + event Ok => { name => 'dup_name' }; + + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + + event Plan => { max => 1 }; + }; + }; + + event Subtest => sub { + call name => 'nested'; + call subevents => array { + event Note => { message => 'nested_before_all' }; + event Note => { message => 'nested_around_all_prefix' }; + + event Subtest => sub { + call name => "nested_$_"; + call subevents => array { + event Note => { message => "nested case $_" }; + + event Skip => {}; + event Skip => {}; + event Skip => {}; + + event Subtest => sub { + call name => 'dup_name'; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + event Note => { message => 'nested_before_each' }; + event Note => { message => 'nested_around_each_prefix' }; + + event Ok => { name => 'dup_name' }; + + event Note => { message => 'nested_after_each' }; + event Note => { message => 'nested_around_each_postfix' }; + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + + event Plan => { max => 1 }; + }; + }; + + event Plan => { max => 4 }; + }; + } for qw/x y/; + + event Note => { message => 'nested_after_all' }; + event Note => { message => 'nested_around_all_postfix' }; + + event Plan => { max => 2 }; + }; + }; + + event Plan => { max => 5 }; + }; + } for qw/x y/; + + event Note => { message => 'root_after_all' }; + event Note => { message => 'root_around_all_postfix' }; + }, + "Got only the events that match the dup_name filter" + ); +}; + +tests root_case => sub { + my $unit = example(); + + my $events = intercept { + Test2::Workflow::Runner->new( + rand => 0, + task => $unit, + filter => {name => 'root_x'} + )->run(); + }; + + is( + $events, + array { + event Note => { message => 'root_before_all' }; + event Note => { message => 'root_around_all_prefix' }; + + event Subtest => sub { + call name => "root_x"; + call subevents => array { + event Note => { message => "root case x" }; + + event Subtest => sub { + call name => $_; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + + if ($_ eq 'root_long') { + event Ok => { name => 'root_long_1' }; + event Ok => { name => 'root_long_2' }; + } + else { + event Ok => { name => $_ }; + } + + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + + event Plan => { max => T() }; + }; + } for qw/root_a root_b root_long dup_name/; + + event Subtest => sub { + call name => 'nested'; + call subevents => array { + event Note => { message => 'nested_before_all' }; + event Note => { message => 'nested_around_all_prefix' }; + + event Subtest => sub { + call name => "nested_$_"; + call subevents => array { + event Note => { message => "nested case $_" }; + + event Subtest => sub { + call name => $_; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + event Note => { message => 'nested_before_each' }; + event Note => { message => 'nested_around_each_prefix' }; + + if ($_ eq 'nested_long') { + event Ok => { name => 'nested_long_1' }; + event Ok => { name => 'nested_long_2' }; + } + else { + event Ok => { name => $_ }; + } + + event Note => { message => 'nested_after_each' }; + event Note => { message => 'nested_around_each_postfix' }; + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + + event Plan => { max => T() }; + }; + } for qw/nested_a nested_b nested_long dup_name/; + + event Plan => { max => 4 }; + }; + } for qw/x y/; + + event Note => { message => 'nested_after_all' }; + event Note => { message => 'nested_around_all_postfix' }; + + event Plan => { max => 2 }; + }; + }; + + event Plan => { max => 5 }; + }; + }; + + event Skip => {}; + + event Note => { message => 'root_after_all' }; + event Note => { message => 'root_around_all_postfix' }; + }, + "Got only the events that match the case filter" + ); +}; + +tests nested_case => sub { + my $unit = example(); + + my $events = intercept { + Test2::Workflow::Runner->new( + rand => 0, + task => $unit, + filter => {name => 'nested_x'} + )->run(); + }; + + is( + $events, + array { + event Note => { message => 'root_before_all' }; + event Note => { message => 'root_around_all_prefix' }; + + event Subtest => sub { + call name => "root_$_"; + call subevents => array { + event Note => { message => "root case $_" }; + + event Skip => {}; + event Skip => {}; + event Skip => {}; + event Skip => {}; + + event Subtest => sub { + call name => 'nested'; + call subevents => array { + event Note => { message => 'nested_before_all' }; + event Note => { message => 'nested_around_all_prefix' }; + + event Subtest => sub { + call name => "nested_x"; + call subevents => array { + event Note => { message => "nested case x" }; + + event Subtest => sub { + call name => $_; + call subevents => array { + event Note => { message => 'root_before_each' }; + event Note => { message => 'root_around_each_prefix' }; + event Note => { message => 'nested_before_each' }; + event Note => { message => 'nested_around_each_prefix' }; + + if ($_ eq 'nested_long') { + event Ok => { name => 'nested_long_1' }; + event Ok => { name => 'nested_long_2' }; + } + else { + event Ok => { name => $_ }; + } + + event Note => { message => 'nested_after_each' }; + event Note => { message => 'nested_around_each_postfix' }; + event Note => { message => 'root_after_each' }; + event Note => { message => 'root_around_each_postfix' }; + + event Plan => { max => T() }; + }; + } for qw/nested_a nested_b nested_long dup_name/; + + event Plan => { max => 4 }; + }; + }; + + event Skip => {}; + + event Note => { message => 'nested_after_all' }; + event Note => { message => 'nested_around_all_postfix' }; + + event Plan => { max => 2 }; + }; + }; + + event Plan => { max => 5 }; + }; + } for qw/x y/; + + event Note => { message => 'root_after_all' }; + event Note => { message => 'root_around_all_postfix' }; + }, + "Got only the events that match the nested case filter" + ); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/behavior/no_done_testing.t b/cpan/Test2-Suite/t/behavior/no_done_testing.t new file mode 100644 index 000000000000..b2af43101d3f --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/no_done_testing.t @@ -0,0 +1,21 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec; + +# Get a non-canon context for the root hub. +my $ctx = sub { + my $ctx = context(); + my $out = $ctx->snapshot; + $ctx->release; + return $out; +}->(); + +tests foo => sub { + # This ok is part of the subtest and goes to the subtest hub + ok(1, "pass"); + + # Use the non-canon root hub context to set a plan. We do this here so that + # no plan is ever set if the test block does not run. + $ctx->plan(1); +}; + +# done_testing intentionally omitted, see #3 diff --git a/cpan/Test2-Suite/t/behavior/no_leaks_any.t b/cpan/Test2-Suite/t/behavior/no_leaks_any.t new file mode 100644 index 000000000000..ecec26887a23 --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/no_leaks_any.t @@ -0,0 +1,17 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec; +use Test2::Util qw/get_tid/; + +my $x; + +tests a => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; +tests b => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; +tests c => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; +tests d => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; +tests e => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; +tests f => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; +tests g => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; + +done_testing; + +die "Ooops, we leaked |$x|" if $x; diff --git a/cpan/Test2-Suite/t/behavior/no_leaks_no_fork.t b/cpan/Test2-Suite/t/behavior/no_leaks_no_fork.t new file mode 100644 index 000000000000..0cef0e4095f7 --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/no_leaks_no_fork.t @@ -0,0 +1,17 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec -no_fork => 1; +use Test2::Util qw/get_tid/; + +my $x; + +tests a => {async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; +tests b => {async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; +tests c => {async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; +tests d => {async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; +tests e => {async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; +tests f => {async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; +tests g => {async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; + +done_testing; + +die "Ooops, we leaked |$x|" if $x; diff --git a/cpan/Test2-Suite/t/behavior/no_leaks_no_iso.t b/cpan/Test2-Suite/t/behavior/no_leaks_no_iso.t new file mode 100644 index 000000000000..65a78c7bd75c --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/no_leaks_no_iso.t @@ -0,0 +1,17 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec -no_threads => 1, -no_fork => 1; +use Test2::Util qw/get_tid/; + +my $x; + +tests a => {async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; +tests b => {async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; +tests c => {async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; +tests d => {async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; +tests e => {async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; +tests f => {async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; +tests g => {async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; + +done_testing; + +die "Ooops, we leaked |$x|" if $x; diff --git a/cpan/Test2-Suite/t/behavior/no_leaks_no_threads.t b/cpan/Test2-Suite/t/behavior/no_leaks_no_threads.t new file mode 100644 index 000000000000..1e8031284e14 --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/no_leaks_no_threads.t @@ -0,0 +1,17 @@ +use Test2::Bundle::Extended; +use Test2::Tools::Spec -no_threads => 1; +use Test2::Util qw/get_tid/; + +my $x; + +tests a => {async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; +tests b => {async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; +tests c => {async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; +tests d => {async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; +tests e => {async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; +tests f => {async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; +tests g => {async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; + +done_testing; + +die "Ooops, we leaked |$x|" if $x; diff --git a/cpan/Test2-Suite/t/behavior/simple.t b/cpan/Test2-Suite/t/behavior/simple.t new file mode 100644 index 000000000000..0ec97ff1dbe7 --- /dev/null +++ b/cpan/Test2-Suite/t/behavior/simple.t @@ -0,0 +1,12 @@ +use strict; +use warnings; + +use Test2::Bundle::Extended; +use Test2::Tools::AsyncSubtest; + +my $ast = async_subtest foo => sub { + ok(1, "Simple"); +}; +$ast->finish; + +done_testing; diff --git a/cpan/Test2-Suite/t/lib/MyTest/Target.pm b/cpan/Test2-Suite/t/lib/MyTest/Target.pm new file mode 100644 index 000000000000..11df57f3645e --- /dev/null +++ b/cpan/Test2-Suite/t/lib/MyTest/Target.pm @@ -0,0 +1,8 @@ +package MyTest::Target; + +use Carp qw/confess/; + +use overload bool => sub { confess( 'illegal use of overloaded bool') } ; +use overload '""' => sub { $_[0] }; + +1; diff --git a/cpan/Test2-Suite/t/load_manual.t b/cpan/Test2-Suite/t/load_manual.t new file mode 100644 index 000000000000..e0092343d5fc --- /dev/null +++ b/cpan/Test2-Suite/t/load_manual.t @@ -0,0 +1,6 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use ok 'Test2::Manual'; +done_testing; diff --git a/cpan/Test2-Suite/t/modules/AsyncSubtest.t b/cpan/Test2-Suite/t/modules/AsyncSubtest.t new file mode 100644 index 000000000000..6773598200ec --- /dev/null +++ b/cpan/Test2-Suite/t/modules/AsyncSubtest.t @@ -0,0 +1,237 @@ +use Test2::Bundle::Extended -target => 'Test2::AsyncSubtest'; +use Test2::AsyncSubtest; +use Test2::Util qw/get_tid CAN_THREAD CAN_REALLY_FORK/; +use Test2::API qw/intercept/; + +ok($INC{'Test2/IPC.pm'}, "Loaded Test2::IPC"); + +# Preserve the API +can_ok $CLASS => qw{ + name hub trace send_to events finished active stack id children pid tid + + context cleave attach detach ready pending run start stop finish wait fork + run_fork run_thread +}; + +my $file = __FILE__; +my $line; +like( + dies { $line = __LINE__; $CLASS->new }, + qr/'name' is a required attribute at \Q$file\E line $line/, + "Must provide name" +); + +my ($one, $two, $three, $hub); +my %lines; +intercept { + $lines{one} = __LINE__ + 1; + $one = $CLASS->new(name => 'one'); + $hub = Test2::API::test2_stack()->top; + + $one->run(sub { + $lines{two} = __LINE__ + 1; + $two = $CLASS->new(name => 'two'); + $two->run(sub { + $lines{three} = __LINE__ + 1; + $three = $CLASS->new(name => 'three'); + }); + }); +}; +isa_ok($one, $CLASS); + +is($one->hub->ast, exact_ref($one), "Can retrieve AST fromthe hub"); + +like( + $one, + { + name => 'one', + send_to => exact_ref($hub), + trace => {frame => [__PACKAGE__, __FILE__, $lines{one}]}, + stack => [], + _in_use => 2, + tid => get_tid, + pid => $$, + finished => 0, + id => 1, + active => 0, + children => [], + hub => meta { prop blessed => 'Test2::AsyncSubtest::Hub' }, + events => array {}, + }, + "Got expected properties from construction part 1" +); + +like( + $two, + { + name => 'two', + send_to => exact_ref($one->hub), + trace => {frame => [__PACKAGE__, __FILE__, $lines{two}]}, + stack => [exact_ref($one)], + _in_use => 1, + tid => get_tid, + pid => $$, + finished => 0, + id => 1, + active => 0, + children => [], + hub => meta { prop blessed => 'Test2::AsyncSubtest::Hub' }, + events => array {}, + }, + "Got expected properties from construction part 2" +); + +like( + $three, + { + name => 'three', + send_to => exact_ref($two->hub), + trace => {frame => [__PACKAGE__, __FILE__, $lines{three}]}, + stack => [exact_ref($one), exact_ref($two)], + _in_use => 0, + tid => get_tid, + pid => $$, + finished => 0, + id => 1, + active => 0, + children => [], + hub => meta { prop blessed => 'Test2::AsyncSubtest::Hub' }, + events => array {}, + }, + "Got expected properties from construction part 3" +); + +$_->finish for $three, $two, $one; + +is( + intercept { + my $st = Test2::AsyncSubtest->new(name => 'collapse: empty'); + $st->finish(collapse => 1); + }, + array { + event Ok => { + pass => 1, + name => 'collapse: empty', + }; + end; + }, + "Got 1 ok event for collapsed/empty subtest" +); + +is( + intercept { + my $st = Test2::AsyncSubtest->new(name => 'collapse: note only'); + $st->run(sub { note "inside" }); + $st->finish(collapse => 1); + }, + array { + event Subtest => sub { + call pass => 1; + call name => 'collapse: note only'; + call subevents => array { + event Note => { message => "inside" }; + event Plan => { max => 0, directive => 'SKIP' }; + end; + }; + }; + end; + }, + "Got subtest event containing only the note and a 0 plan" +); + +is( + intercept { + my $st = Test2::AsyncSubtest->new(name => 'collapse: full'); + $st->run(sub { ok(1, "test") }); + $st->finish(collapse => 1); + }, + array { + event Subtest => sub { + call pass => 1; + call name => 'collapse: full'; + call subevents => array { + event Ok => { pass => 1 }; + event Plan => { max => 1 }; + end; + }; + }; + end; + }, + "Got full subtest" +); + +is( + intercept { + my $st = Test2::AsyncSubtest->new(name => 'collapse: no assert, but fail'); + $st->hub->set_failed(1); + $st->finish(collapse => 1); + }, + array { + fail_events Ok => sub { + call pass => 0; + call name => 'collapse: no assert, but fail'; + }; + end; + }, + "Failure with no assertion (no test count)" +); + + +is( + intercept { + my $st = Test2::AsyncSubtest->new(name => 'skip test'); + $st->finish(skip => "foo bar"); + }, + array { + event Skip => { name => 'skip test', reason => 'foo bar' }; + end; + }, + "Can skip" +); + +my $events = intercept { + my $control = mock 'Test2::Hub' => ( + override => [ is_local => sub { 0 } ], + ); + + my $st = Test2::AsyncSubtest->new(name => 'early'); + $st->run(sub { diag("We want to see this message or people die!") }); + $control = undef; + $st->finish(); +}; + +is( + $events->[0]->{subevents}->[0]->{message}, + "We want to see this message or people die!", + "Can send non-local non-attached events" +); + +# TODO Make this into an actual test, we want it to cause an explosion, but +# intercept is not string enough to contain that explosion... +#$events = intercept { +# my $control = mock 'Test2::Hub' => ( +# override => [ is_local => sub { 0 } ], +# ); +# +# my $st = Test2::AsyncSubtest->new(name => 'early'); +# +# local $SIG{PIPE} = 'IGNORE'; +# pipe(my $rh, my $wh) or die "Could not pipe"; +# my $pid = fork(); +# if ($pid) { +# $st->run(sub{ ok(1) }); +# $control = undef; +# $st->finish(); +# print $wh "ready\n"; +# $wh->flush; +# close($wh); +# waitpid($pid, 0); +# } +# else { +# my $ready = <$rh>; +# $st->run(sub{ diag "Too Late" }); +# exit 0; +# } +#}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Attach.t b/cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Attach.t new file mode 100644 index 000000000000..5ea0770910db --- /dev/null +++ b/cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Attach.t @@ -0,0 +1,38 @@ +use Test2::Bundle::Extended -target => 'Test2::AsyncSubtest::Event::Attach'; +use Test2::AsyncSubtest::Event::Attach; + +isa_ok($CLASS, 'Test2::Event'); + +can_ok($CLASS, 'id'); + +require Test2::AsyncSubtest::Hub; +my $hub = Test2::AsyncSubtest::Hub->new(); +my $events = []; +$hub->listen(sub { + my ($h, $e) = @_; + push @$events => $e; +}); + +my $one = $CLASS->new(id => 123, trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__])); + +$one->callback($hub); + +like( + pop(@$events), + event(Exception => sub { error => qr/Invalid AsyncSubtest attach ID: 123/ }), + "Got exception for attached id" +); + +$hub->{ast_ids}->{123} = 0; +$one->callback($hub); +is($hub->ast_ids->{123}, 1, "Filled slot"); +ok(!@$events, "no events added"); + +$one->callback($hub); +like( + pop(@$events), + event(Exception => sub { error => qr/AsyncSubtest ID 123 already attached/ }), + "Got exception for invalid id" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Detach.t b/cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Detach.t new file mode 100644 index 000000000000..8171a855325a --- /dev/null +++ b/cpan/Test2-Suite/t/modules/AsyncSubtest/Event/Detach.t @@ -0,0 +1,38 @@ +use Test2::Bundle::Extended -target => 'Test2::AsyncSubtest::Event::Detach'; +use Test2::AsyncSubtest::Event::Detach; + +isa_ok($CLASS, 'Test2::Event'); + +can_ok($CLASS, 'id'); + +require Test2::AsyncSubtest::Hub; +my $hub = Test2::AsyncSubtest::Hub->new(); +my $events = []; +$hub->listen(sub { + my ($h, $e) = @_; + push @$events => $e; +}); + +my $one = $CLASS->new(id => 123, trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__])); + +$one->callback($hub); +like( + pop(@$events), + event(Exception => sub { error => qr/Invalid AsyncSubtest attach ID: 123/ }), + "Got exception for invalid id" +); + +$hub->{ast_ids}->{123} = 0; +$one->callback($hub); +like( + pop(@$events), + event(Exception => sub { error => qr/AsyncSubtest ID 123 is not attached/ }), + "Got exception for unattached id" +); + +$hub->{ast_ids}->{123} = 1; +$one->callback($hub); +ok(!exists($hub->ast_ids->{123}), "deleted slot"); +ok(!@$events, "no events added"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/AsyncSubtest/Hub.t b/cpan/Test2-Suite/t/modules/AsyncSubtest/Hub.t new file mode 100644 index 000000000000..ccb12fdbebff --- /dev/null +++ b/cpan/Test2-Suite/t/modules/AsyncSubtest/Hub.t @@ -0,0 +1,8 @@ +use Test2::Bundle::Extended -target => 'Test2::AsyncSubtest::Hub'; +use Test2::AsyncSubtest::Hub; + +isa_ok($CLASS, 'Test2::Hub::Subtest'); + +ok(!$CLASS->can('inherit')->(), "inherit does nothing"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Bundle.t b/cpan/Test2-Suite/t/modules/Bundle.t new file mode 100644 index 000000000000..fcfac2d74d38 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Bundle.t @@ -0,0 +1,7 @@ +use Test2::Bundle::Extended; + +use Test2::Bundle; + +pass("Loaded Test2::Bundle"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Bundle/Extended.t b/cpan/Test2-Suite/t/modules/Bundle/Extended.t new file mode 100644 index 000000000000..4217fc14e369 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Bundle/Extended.t @@ -0,0 +1,94 @@ +use Test2::Bundle::Extended; +use Test2::API qw/test2_stack/; +use PerlIO; +# HARNESS-NO-FORMATTER + +imported_ok qw{ + ok pass fail diag note todo skip + plan skip_all done_testing bail_out + + gen_event + + intercept context + + cmp_ok + + subtest + can_ok isa_ok DOES_ok + set_encoding + imported_ok not_imported_ok + ref_ok ref_is ref_is_not + mock mocked + + dies lives try_ok + + is like isnt unlike + match mismatch validator + hash array object meta number string bool check_isa + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event fail_events + exact_ref +}; + +ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); +ok(defined(Test2::Plugin::SRand->seed), "SRand is loaded"); + +subtest strictures => sub { + local $^H; + my $hbefore = $^H; + Test2::Bundle::Extended->import; + my $hafter = $^H; + + my $strict = do { local $^H; strict->import(); $^H }; + + ok($strict, 'sanity, got $^H value for strict'); + ok(!($hbefore & $strict), "strict is not on before loading Test2::Bundle::Extended"); + ok(($hafter & $strict), "strict is on after loading Test2::Bundle::Extended"); +}; + +subtest warnings => sub { + local ${^WARNING_BITS}; + my $wbefore = ${^WARNING_BITS} || ''; + Test2::Bundle::Extended->import; + my $wafter = ${^WARNING_BITS} || ''; + + my $warnings = do { local ${^WARNING_BITS}; 'warnings'->import(); ${^WARNING_BITS} || '' }; + + ok($warnings, 'sanity, got ${^WARNING_BITS} value for warnings'); + ok($wbefore ne $warnings, "warnings are not on before loading Test2::Bundle::Extended") || diag($wbefore, "\n", $warnings); + ok(($wafter & $warnings), "warnings are on after loading Test2::Bundle::Extended"); +}; + +subtest utf8 => sub { + ok(utf8::is_utf8("癸"), "utf8 pragma is on"); + + # -2 cause the subtest adds to the stack + my $format = test2_stack()->[-2]->format; + my $handles = $format->handles or return; + for my $hn (0 .. @$handles) { + my $h = $handles->[$hn] || next; + my $layers = { map {$_ => 1} PerlIO::get_layers($h) }; + ok($layers->{utf8}, "utf8 is on for formatter handle $hn"); + } +}; + +subtest "rename imports" => sub { + package A::Consumer; + use Test2::Bundle::Extended ':v1', '!subtest', subtest => {-as => 'a_subtest'}; + imported_ok('a_subtest'); + not_imported_ok('subtest'); +}; + +subtest "no meta" => sub { + package B::Consumer; + use Test2::Bundle::Extended '!meta'; + imported_ok('meta_check'); + not_imported_ok('meta'); +}; + +done_testing; + +1; diff --git a/cpan/Test2-Suite/t/modules/Bundle/More.t b/cpan/Test2-Suite/t/modules/Bundle/More.t new file mode 100644 index 000000000000..3e87e83a456d --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Bundle/More.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test2::Bundle::More; +use Test2::Tools::Exports; + +imported_ok qw{ + ok pass fail skip todo diag note + plan skip_all done_testing BAIL_OUT + + is isnt like unlike is_deeply cmp_ok isa_ok + + can_ok + subtest +}; + +ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); + +done_testing; + +1; + +__END__ + diff --git a/cpan/Test2-Suite/t/modules/Bundle/Simple.t b/cpan/Test2-Suite/t/modules/Bundle/Simple.t new file mode 100644 index 000000000000..0601fe4f7f49 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Bundle/Simple.t @@ -0,0 +1,15 @@ +use strict; +use warnings; +use Test2::Bundle::Simple; +use Test2::Tools::Exports; + +imported_ok qw/ok plan done_testing skip_all/; + +ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); + +done_testing; + +1; + +__END__ + diff --git a/cpan/Test2-Suite/t/modules/Compare.t b/cpan/Test2-Suite/t/modules/Compare.t new file mode 100644 index 000000000000..391fc8367cc5 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare.t @@ -0,0 +1,151 @@ +use Test2::Tools::Defer; +use strict; +use warnings; + +# Make sure convert loads necessary modules (must do before loading the +# extended bundle) +BEGIN { + require Test2::Compare; + def ok => (defined Test2::Compare::convert(undef), "convert returned something to us"); + def ok => ($INC{'Test2/Compare/Undef.pm'}, "loaded the Test2::Compare::Undef module"); +} + +use Test2::Bundle::Extended; +use Test2::API qw/intercept/; +use Data::Dumper; + +use Test2::Compare qw{ + compare get_build push_build pop_build build + strict_convert relaxed_convert +}; +pass "Loaded Test2::Compare"; + +imported_ok qw{ + compare get_build push_build pop_build build + strict_convert relaxed_convert +}; + +do_def; + +{ + package Fake::Check; + + sub run { + my $self = shift; + return {@_, self => $self} + } +} + +my $check = bless {}, 'Fake::Check'; +my $convert = sub { $_[-1]->{ran}++; $_[-1] }; +my $got = compare('foo', $check, $convert); + +like( + $got, + { + self => {ran => 1}, + id => undef, + got => 'foo', + convert => sub { $_ == $convert }, + seen => {}, + }, + "check got expected args" +); + +is(get_build(), undef, "no build"); + +like( + dies { pop_build(['a']) }, + qr/INTERNAL ERROR: Attempted to pop incorrect build, have undef, tried to pop ARRAY/, + "Got error popping from nothing" +); + +push_build(['a']); +is(get_build(), ['a'], "pushed build"); + +like( + dies { pop_build() }, + qr/INTERNAL ERROR: Attempted to pop incorrect build, have ARRAY\(.*\), tried to pop undef/, + "Got error popping undef" +); + +like( + dies { pop_build(['a']) }, + qr/INTERNAL ERROR: Attempted to pop incorrect build, have ARRAY\(.*\), tried to pop ARRAY/, + "Got error popping wrong ref" +); + +# Don't ever actually do this... +ok(pop_build(get_build()), "Popped"); + +my $inner; +my $build = sub { build('Test2::Compare::Array', sub { + local $_ = 1; + $inner = get_build(); +}) }->(); +is($build->lines, [__LINE__ - 4, __LINE__ - 1], "got lines"); +is($build->file, __FILE__, "got file"); + +ref_is($inner, $build, "Build was set inside block"); + +like( + dies { my $x = build('Test2::Compare::Array', sub { die 'xxx' }) }, + qr/xxx at/, + "re-threw exception" +); + +like( + dies { build('Test2::Compare::Array', sub { }) }, + qr/should not be called in void context/, + "You need to retain the return from build" +); + +subtest convert => sub { + my $true = do { bless \(my $dummy = 1), "My::Boolean" }; + my $false = do { bless \(my $dummy = 0), "My::Boolean" }; + + my @sets = ( + ['a', 'String', 'String'], + [undef, 'Undef', 'Undef'], + ['', 'String', 'String'], + [1, 'String', 'String'], + [0, 'String', 'String'], + [[], 'Array', 'Array'], + [{}, 'Hash', 'Hash'], + [qr/x/, 'Regex', 'Pattern'], + [sub { 1 }, 'Ref', 'Custom'], + [\*STDERR, 'Ref', 'Ref'], + [\'foo', 'Scalar', 'Scalar'], + [\v1.2.3, 'Scalar', 'Scalar'], + [$true, 'Scalar', 'Scalar'], + [$false, 'Scalar', 'Scalar'], + + [ + bless({}, 'Test2::Compare::Base'), + 'Base', + 'Base' + ], + + [ + bless({expect => 'a'}, 'Test2::Compare::Wildcard'), + 'String', + 'String', + ], + ); + + for my $set (@sets) { + my ($item, $strict, $relaxed) = @$set; + + my $name = defined $item ? "'$item'" : 'undef'; + + my $gs = strict_convert($item); + my $st = join '::', grep {$_} 'Test2::Compare', $strict; + ok($gs->isa($st), "$name -> $st") || diag Dumper($item); + + my $gr = relaxed_convert($item); + my $rt = join '::', grep {$_} 'Test2::Compare', $relaxed; + ok($gr->isa($rt), "$name -> $rt") || diag Dumper($item); + } +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Array.t b/cpan/Test2-Suite/t/modules/Compare/Array.t new file mode 100644 index 000000000000..aed3f73b6915 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Array.t @@ -0,0 +1,266 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Array'; + +use lib 't/lib'; + +isa_ok($CLASS, 'Test2::Compare::Base'); +is($CLASS->name, '', "got name"); + +subtest construction => sub { + my $one = $CLASS->new(); + isa_ok($one, $CLASS); + is($one->items, {}, "created items as a hash"); + is($one->order, [], "created order as an array"); + + $one = $CLASS->new(items => { 1 => 'a', 2 => 'b' }); + is($one->items, { 1 => 'a', 2 => 'b' }, "used items as specified"); + is($one->order, [ 1, 2 ], "generated order"); + + like( + dies { $CLASS->new(items => { a => 1, b => 2 }) }, + qr/All indexes listed in the 'items' hashref must be numeric/, + "Indexes must be numeric" + ); + like( + dies { $CLASS->new(items => {}, order => [ 'a' ]) }, + qr/All indexes listed in the 'order' arrayref must be numeric/, + "Indexes must be numeric" + ); + + $one = $CLASS->new(inref => ['a', 'b']); + is($one->items, { 0 => 'a', 1 => 'b' }, "Generated items"); + is($one->order, [ 0, 1 ], "generated order"); + + like( + dies { $CLASS->new(inref => [ 'a' ], items => { 0 => 'a' }) }, + qr/Cannot specify both 'inref' and 'items'/, + "Cannot specify inref and items" + ); + like( + dies { $CLASS->new(inref => [ 'a' ], order => [ 0 ]) }, + qr/Cannot specify both 'inref' and 'order'/, + "Cannot specify inref and order" + ); + like( + dies { $CLASS->new(inref => { 1 => 'a' }) }, + qr/'inref' must be an array reference, got 'HASH\(.+\)'/, + "inref must be an array" + ); +}; + +subtest verify => sub { + my $one = $CLASS->new; + + is($one->verify(exists => 0), 0, "did not get anything"); + is($one->verify(exists => 1, got => undef), 0, "undef is not an array"); + is($one->verify(exists => 1, got => 0), 0, "0 is not an array"); + is($one->verify(exists => 1, got => 1), 0, "1 is not an array"); + is($one->verify(exists => 1, got => 'string'), 0, "'string' is not an array"); + is($one->verify(exists => 1, got => {}), 0, "a hash is not an array"); + is($one->verify(exists => 1, got => []), 1, "an array is an array"); +}; + +subtest top_index => sub { + my $one = $CLASS->new; + is($one->top_index, undef, "no indexes"); + + $one = $CLASS->new(inref => [ 'a', 'b', 'c' ]); + is($one->top_index, 2, "got top index"); + + $one = $CLASS->new(inref => [ 'a' ]); + is($one->top_index, 0, "got top index"); + + $one = $CLASS->new(inref => [ ]); + is($one->top_index, undef, "no indexes"); + + $one = $CLASS->new(order => [ 0, 1, 2, sub { 1 }], items => { 0 => 'a', 1 => 'b', 2 => 'c' }); + is($one->top_index, 2, "got top index, despite ref"); +}; + +subtest add_item => sub { + my $one = $CLASS->new(); + + $one->add_item('a'); + $one->add_item(1 => 'b'); + $one->add_item(3 => 'd'); + + like( + dies { $one->add_item(2 => 'c') }, + qr/elements must be added in order!/, + "Items must be added in order" + ); + + $one->add_item(8 => 'x'); + $one->add_item('y'); + + is( + $one->items, + { 0 => 'a', 1 => 'b', 3 => 'd', 8 => 'x', 9 => 'y' }, + "Expected items" + ); + + is($one->order, [0, 1, 3, 8, 9], "got order"); +}; + +subtest add_filter => sub { + my $one = $CLASS->new; + + $one->add_item('a'); + my $f = sub { grep { m/[a-z]/ } @_ }; + $one->add_filter($f); + $one->add_item('b'); + + like( + dies { $one->add_filter }, + qr/A single coderef is required/, + "No filter specified" + ); + like( + dies { $one->add_filter(1) }, + qr/A single coderef is required/, + "Not a valid filter" + ); + like( + dies { $one->add_filter(undef) }, + qr/A single coderef is required/, + "Filter must be defined" + ); + like( + dies { $one->add_filter(sub { 1 }, sub { 2 }) }, + qr/A single coderef is required/, + "Too many filters" + ); + like( + dies { $one->add_filter({}) }, + qr/A single coderef is required/, + "Not a coderef" + ); + + is( $one->order, [0, $f, 1], "added filter to order array"); +}; + +subtest deltas => sub { + my $conv = Test2::Compare->can('strict_convert'); + + my %params = (exists => 1, convert => $conv, seen => {}); + + my $inref = ['a', 'b']; + my $one = $CLASS->new(inref => $inref); + + like( + [$one->deltas(%params, got => ['a', 'b'])], + [], + "No delta, no diff" + ); + + like( + [$one->deltas(%params, got => ['a'])], + [ + { + dne => 'got', + id => [ARRAY => 1], + got => undef, + } + ], + "Got the delta for the missing value" + ); + + like( + [$one->deltas(%params, got => ['a', 'a'])], + [ + { + dne => DNE, + id => [ARRAY => 1], + got => 'a', + chk => {input => 'b'}, + } + ], + "Got the delta for the incorrect value" + ); + + like( + [$one->deltas(%params, got => ['a', 'b', 'a', 'a'])], + [], + "No delta, not checking ending" + ); + + $one->set_ending(1); + like( + [$one->deltas(%params, got => ['a', 'b', 'a', 'x'])], + array { + item 0 => { + dne => 'check', + id => [ARRAY => 2], + got => 'a', + check => DNE, + }; + item 1 => { + dne => 'check', + id => [ARRAY => 3], + got => 'x', + check => DNE, + }; + end(), + }, + "Got 2 deltas for extra items" + ); + + $one = $CLASS->new(); + $one->add_item('a'); + $one->add_filter( + sub { + grep { m/[a-z]/ } @_; + } + ); + $one->add_item('b'); + + is( + [$one->deltas(%params, got => ['a', 1, 2, 'b'])], + [], + "Filter worked" + ); + + like( + [$one->deltas(%params, got => ['a', 1, 2, 'a'])], + [ + { + dne => DNE, + id => [ARRAY => 1], + got => 'a', + chk => {input => 'b'}, + } + ], + "Filter worked, but input is still wrong" + ); +}; + +{ + package Foo::Array; + use base 'MyTest::Target'; + + sub new { + my $class = shift; + bless [ @_ ] , $class; + } +} + +subtest objects_as_arrays => sub { + + my $o1 = Foo::Array->new( 'b' ) ; + my $o2 = Foo::Array->new( 'b' ) ; + + is ( $o1, $o2, "same" ); +}; + +subtest add_prop => sub { + my $one = $CLASS->new(); + + ok(!$one->meta, "no meta yet"); + $one->add_prop('size' => 1); + isa_ok($one->meta, 'Test2::Compare::Meta'); + is(@{$one->meta->items}, 1, "1 item"); + + $one->add_prop('reftype' => 'ARRAY'); + is(@{$one->meta->items}, 2, "2 items"); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Bag.t b/cpan/Test2-Suite/t/modules/Compare/Bag.t new file mode 100644 index 000000000000..f623d5898eb0 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Bag.t @@ -0,0 +1,164 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Bag'; + +isa_ok($CLASS, 'Test2::Compare::Base'); +is($CLASS->name, '', "got name"); + +subtest construction => sub { + my $one = $CLASS->new(); + isa_ok($one, $CLASS); + is($one->items, [], "created items as an array"); +}; + +subtest verify => sub { + my $one = $CLASS->new; + + is($one->verify(exists => 0), 0, "did not get anything"); + is($one->verify(exists => 1, got => undef), 0, "undef is not an array"); + is($one->verify(exists => 1, got => 0), 0, "0 is not an array"); + is($one->verify(exists => 1, got => 1), 0, "1 is not an array"); + is($one->verify(exists => 1, got => 'string'), 0, "'string' is not an array"); + is($one->verify(exists => 1, got => {}), 0, "a hash is not an array"); + is($one->verify(exists => 1, got => []), 1, "an array is an array"); +}; + +subtest add_item => sub { + my $one = $CLASS->new(); + + $one->add_item('a'); + $one->add_item(1 => 'b'); + $one->add_item(3 => 'd'); + + ok( + lives { $one->add_item(2 => 'c') }, + "Indexes are ignored", + ); + + $one->add_item(8 => 'x'); + $one->add_item('y'); + + is( + $one->items, + [ 'a', 'b', 'd', 'c', 'x', 'y' ], + "Expected items", + ); +}; + +subtest deltas => sub { + my $conv = Test2::Compare->can('strict_convert'); + + my %params = (exists => 1, convert => $conv, seen => {}); + + my $items = ['a', 'b']; + my $one = $CLASS->new(items => $items); + + like( + [$one->deltas(%params, got => ['a', 'b'])], + [], + "No delta, no diff" + ); + + like( + [$one->deltas(%params, got => ['b', 'a'])], + [], + "No delta, no diff, order is ignored" + ); + + like( + [$one->deltas(%params, got => ['a'])], + [ + { + dne => 'got', + id => [ARRAY => '*'], + got => undef,, + chk => {input => 'b'}, + } + ], + "Got the delta for the missing value" + ); + + like( + [$one->deltas(%params, got => ['a', 'a'])], + [ + { + dne => 'got', + id => [ARRAY => '*'], + got => undef, + chk => {input => 'b'}, + } + ], + "Got the delta for the incorrect value" + ); + + like( + [$one->deltas(%params, got => ['a', 'b', 'a', 'a'])], + [], + "No delta, not checking ending" + ); + + $one->set_ending(1); + like( + [$one->deltas(%params, got => ['a', 'b', 'a', 'x'])], + array { + item 0 => { + dne => 'check', + id => [ARRAY => 2], + got => 'a', + check => DNE, + }; + item 1 => { + dne => 'check', + id => [ARRAY => 3], + got => 'x', + check => DNE, + }; + end(), + }, + "Got 2 deltas for extra items" + ); + + subtest 'duplicate items' => sub { + my $items = ['a', 'a']; + my $one = $CLASS->new(items => $items); + + like( + [$one->deltas(%params, got => ['a', 'a'])], + [], + "No delta, no diff" + ); + + like( + [$one->deltas(%params, got => ['a', 'a', 'a'])], + [], + "No delta, not checking ending" + ); + + $one->set_ending(1); + like( + [$one->deltas(%params, got => ['a', 'a', 'a'])], + array { + item 0 => { + dne => 'check', + id => [ARRAY => 2], + got => 'a', + check => DNE, + }; + end(), + }, + "Got the delta for extra item" + ); + }; +}; + +subtest add_prop => sub { + my $one = $CLASS->new(); + + ok(!$one->meta, "no meta yet"); + $one->add_prop('size' => 1); + isa_ok($one->meta, 'Test2::Compare::Meta'); + is(@{$one->meta->items}, 1, "1 item"); + + $one->add_prop('reftype' => 'ARRAY'); + is(@{$one->meta->items}, 2, "2 items"); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Base.t b/cpan/Test2-Suite/t/modules/Compare/Base.t new file mode 100644 index 000000000000..330e5ddbb25b --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Base.t @@ -0,0 +1,59 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Base'; + +my $one = $CLASS->new(); +isa_ok($one, $CLASS); + +is($one->delta_class, 'Test2::Compare::Delta', "Got expected delta class"); + +is([$one->deltas], [], "no deltas"); +is([$one->got_lines], [], "no lines"); + +is($one->operator, '', "no default operator"); + +like(dies { $one->verify }, qr/unimplemented/, "unimplemented"); +like(dies { $one->name }, qr/unimplemented/, "unimplemented"); + +{ + no warnings 'redefine'; + *Test2::Compare::Base::name = sub { 'bob' }; + *Test2::Compare::Base::verify = sub { shift; my %p = @_; $p{got} eq 'xxx' }; +} + +is($one->render, 'bob', "got name"); + +is( + [$one->run(id => 'xxx', got => 'xxx', convert => sub { $_[-1] }, seen => {})], + [], + "Valid" +); + +is( + [$one->run(id => [META => 'xxx'], got => 'xxy', convert => sub { $_[-1] }, seen => {})], + [ + { + verified => '', + id => [META => 'xxx'], + got => 'xxy', + chk => {%$one}, + children => [], + } + ], + "invalid" +); + +$one = $CLASS->new; +is($one->lines, [], "no lines"); + +my $line1 = __LINE__ + 1; +$one = $CLASS->new(builder => sub { + print "A"; + print "B"; +}); +my $line2 = __LINE__ - 1; + +is($one->lines, [$line1, $line2], "got lines from builder."); + +$one = $CLASS->new(called => ['foo', 'bar', 42]); +is($one->lines, [42], "got line from caller"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Bool.t b/cpan/Test2-Suite/t/modules/Compare/Bool.t new file mode 100644 index 000000000000..a5480c4b6672 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Bool.t @@ -0,0 +1,11 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Bool'; + +my $one = $CLASS->new(input => 'foo'); +is($one->name, '', "Got name"); +is($one->operator, '==', "Got operator"); + +$one = $CLASS->new(input => 0, negate => 1); +is($one->name, '', "Got name"); +is($one->operator, '!=', "Got operator"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Custom.t b/cpan/Test2-Suite/t/modules/Compare/Custom.t new file mode 100644 index 000000000000..e411b67a584c --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Custom.t @@ -0,0 +1,59 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Custom'; +use Test2::API qw(intercept); + +my $pass = $CLASS->new(code => sub { 1 }); +my $fail = $CLASS->new(code => sub { 0 }); + +isa_ok($pass, $CLASS, 'Test2::Compare::Base'); +isa_ok($fail, $CLASS, 'Test2::Compare::Base'); + +ok($pass->verify(got => "anything"), "always passes"); +ok(!$fail->verify(got => "anything"), "always fails"); + +is($pass->operator, 'CODE(...)', "default operator"); +is($pass->name, '', "default name"); +ok(!$pass->stringify_got, "default stringify_got"); + +{ + package My::String; + use overload '""' => sub { "xxx" }; +} + +my $stringify = $CLASS->new(code => sub { 0 }, stringify_got => 1); +ok($stringify->stringify_got, "custom stringify_got()"); +like( + intercept { + my $object = bless {}, 'My::String'; + is($object => $stringify); + }, + array { + event Fail => sub { + call info => array { + item hash { + field table => hash { + field rows => [['', '', 'xxx', 'CODE(...)', '']]; + }; + }; + }; + }; + }, + "stringified object in test output" +); + +my $args; +my $under; +my $one = $CLASS->new(code => sub { $args = {@_}; $under = $_ }, name => 'the name', operator => 'the op'); +$_ = undef; +$one->verify(got => 'foo', exists => 'x'); +is($_, undef, '$_ restored'); + +is($args, {got => 'foo', exists => 'x', operator => 'the op', name => 'the name'}, "Got the expected args"); +is($under, 'foo', '$_ was set'); + +like( + dies { $CLASS->new() }, + qr/'code' is required/, + "Need to provide code" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Delta.t b/cpan/Test2-Suite/t/modules/Compare/Delta.t new file mode 100644 index 000000000000..e0997e49b87f --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Delta.t @@ -0,0 +1,605 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Delta'; + +BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } + +can_ok($CLASS, qw/check/); +is( + $CLASS->can('chk'), + $CLASS->can('check'), + "chk is aliased to check" +); + +my $one = $CLASS->new(); +isa_ok($one, $CLASS); + +my $check1 = Test2::Compare::String->new(input => 'x'); +my $check2 = Test2::Compare::String->new(input => 'y'); + +$one = $CLASS->new(check => $check1); +ref_is($one->chk, $check1, "Got our check"); +ref_is($one->check, $check1, "Got our check aliased"); + +$one = $CLASS->new(chk => $check2); +ref_is($one->chk, $check2, "Got our check"); +ref_is($one->check, $check2, "Got our check aliased"); + +like( + dies { $CLASS->new(check => $check1, chk => $check2) }, + qr/Cannot specify both 'check' and 'chk' as arguments/, + "Cannot specify both chk and check" +); + +subtest render_got => sub { + my $one = $CLASS->new; + + is($one->render_got, '', "'got' is undef"); + + $one->set_exception('foo'); + is($one->render_got, '', "Exception always wins"); + + $one->set_exception(undef); + $one->set_dne('got'); + is($one->render_got, '', "'got' does not exist"); + + $one->set_dne('check'); + is($one->render_got, '', "'got' does not exist"); + + $one->set_dne(undef); + $one->set_got('a'); + is($one->render_got, 'a', "'got' value"); + + $one->set_got({}); + like($one->render_got, qr/HASH\(.*\)/, "'got' ref value"); +}; + +subtest render_check => sub { + my $one = $CLASS->new; + my $check = Test2::Compare::String->new(input => 'xyz'); + + is($one->render_check, '', "check is undef"); + + $one->set_dne('got'); + is($one->render_check, '', "check is undef and dne is 'got'"); + + $one->set_dne('check'); + is($one->render_check, '', "check does not exit"); + + $one->set_dne(undef); + $one->set_check($check); + is($one->render_check, $check->render, "valid check is rendered"); +}; + +subtest _full_id => sub { + my $fid = $CLASS->can('_full_id'); + + is($fid->(undef, 'xxx'), '', "no type means "); + is($fid->('META', 'xxx'), '', "META type means "); + is($fid->('SCALAR', '$*'), '$*', "SCALAR type means ID is unchanged"); + is($fid->('HASH', 'xxx'), '{xxx}', "HASH type means ID is wrapped in {}"); + is($fid->('ARRAY', '12'), '[12]', "ARRAY type means ID is wrapped in []"); + is($fid->('METHOD', 'foo'), 'foo()', "METHOD type gets () postfix"); +}; + +subtest _arrow_id => sub { + my $aid = $CLASS->can('_arrow_id'); + + is($aid->('xxx', undef), ' ', "undef gets a space, not an arrow"); + is($aid->('xxx', 'META'), ' ', "Meta gets a space, not an arrow"); + is($aid->('xxx', 'METHOD'), '->', "Method always needs an arrow"); + is($aid->('xxx', 'SCALAR'), '->', "Scalar always needs an arrow"); + is($aid->('xxx', 'HASH'), '->', "Hash usually needs an arrow"); + is($aid->('xxx', 'ARRAY'), '->', "Array usually needs an arrow"); + is($aid->('{xxx}', 'HASH'), '', "Hash needs no arrow after hash"); + is($aid->('{xxx}', 'ARRAY'), '', "Array needs no arrow after hash"); + is($aid->('[xxx]', 'HASH'), '', "Hash needs no arrow after array"); + is($aid->('[xxx]', 'ARRAY'), '', "Array needs no arrow after array"); + is($aid->('', 'xxx'), '->', "Need an arrow after meta, or after a method"); + is($aid->('xxx()', 'xxx'), '->', "Need an arrow after meta, or after a method"); + is($aid->('$VAR', 'xxx'), '->', "Need an arrow after the initial ref"); + is($aid->('xxx', ''), ' ', "space"); + is($aid->('', ''), '', "No arrow needed"); +}; + +subtest _join_id => sub { + my $jid = $CLASS->can('_join_id'); + + is($jid->('{path}', [undef, 'id']), "{path} ", "Hash + undef"); + is($jid->('[path]', [undef, 'id']), "[path] ", "Array + undef"); + is($jid->('path', [undef, 'id']), "path ", "path + undef"); + is($jid->('', [undef, 'id']), " ", "meta + undef"); + is($jid->('path()', [undef, 'id']), "path() ", "meth + undef"); + is($jid->('$VAR', [undef, 'id']), '$VAR ', '$VAR + undef'); + is($jid->('', [undef, 'id']), "", "empty + undef"); + + is($jid->('{path}', ['META', 'id']), "{path} ", "hash + meta"); + is($jid->('[path]', ['META', 'id']), "[path] ", "array + meta"); + is($jid->('path', ['META', 'id']), "path ", "path + meta"); + is($jid->('', ['META', 'id']), " ", "meta + meta"); + is($jid->('path()', ['META', 'id']), "path() ", "meth + meta"); + is($jid->('$VAR', ['META', 'id']), '$VAR ', '$VAR + meta'); + is($jid->('', ['META', 'id']), "", "empty + meta"); + + is($jid->('{path}', ['SCALAR', '$*']), '{path}->$*', "Hash + scalar"); + is($jid->('[path]', ['SCALAR', '$*']), '[path]->$*', "Array + scalar"); + is($jid->('path', ['SCALAR', '$*']), 'path->$*', "Path + scalar"); + is($jid->('', ['SCALAR', '$*']), '->$*', "Meta + scalar"); + is($jid->('path()', ['SCALAR', '$*']), 'path()->$*', "Meth + scalar"); + is($jid->('$VAR', ['SCALAR', '$*']), '$VAR->$*', '$VAR + scalar'); + is($jid->('', ['SCALAR', '$*']), '$*', "Empty + scalar"); + + is($jid->('{path}', ['HASH', 'id']), "{path}{id}", "Hash + hash"); + is($jid->('[path]', ['HASH', 'id']), "[path]{id}", "Array + hash"); + is($jid->('path', ['HASH', 'id']), "path->{id}", "Path + hash"); + is($jid->('', ['HASH', 'id']), "->{id}", "Meta + hash"); + is($jid->('path()', ['HASH', 'id']), "path()->{id}", "Meth + hash"); + is($jid->('$VAR', ['HASH', 'id']), '$VAR->{id}', '$VAR + hash'); + is($jid->('', ['HASH', 'id']), "{id}", "Empty + hash"); + + is($jid->('{path}', ['ARRAY', '12']), "{path}[12]", "Hash + array"); + is($jid->('[path]', ['ARRAY', '12']), "[path][12]", "Array + array"); + is($jid->('path', ['ARRAY', '12']), "path->[12]", "Path + array"); + is($jid->('', ['ARRAY', '12']), "->[12]", "Meta + array"); + is($jid->('path()', ['ARRAY', '12']), "path()->[12]", "Meth + array"); + is($jid->('$VAR', ['ARRAY', '12']), '$VAR->[12]', '$VAR + array'); + is($jid->('', ['ARRAY', '12']), "[12]", "Empty + array"); + + is($jid->('{path}', ['METHOD', 'id']), "{path}->id()", "Hash + method"); + is($jid->('[path]', ['METHOD', 'id']), "[path]->id()", "Array + method"); + is($jid->('path', ['METHOD', 'id']), "path->id()", "Path + method"); + is($jid->('', ['METHOD', 'id']), "->id()", "Meta + method"); + is($jid->('path()', ['METHOD', 'id']), "path()->id()", "Meth + method"); + is($jid->('$VAR', ['METHOD', 'id']), '$VAR->id()', '$VAR + method'); + is($jid->('', ['METHOD', 'id']), "id()", "Empty + method"); +}; + +subtest should_show => sub { + my $one = $CLASS->new(verified => 0); + ok($one->should_show, "not verified, always show"); + + $one->set_verified(1); + ok(!$one->should_show, "verified, do not show"); + + my $check = Test2::Compare::String->new(input => 'xyz'); + $one->set_chk($check); + ok(!$one->should_show, "verified, check is uninteresting"); + + $check->set_lines([1,2]); + ok(!$one->should_show, "verified, check has lines but no file"); + + $check->set_file('foo'); + ok(!$one->should_show, "verified, check has lines different file"); + + $check->set_file(__FILE__); + ok($one->should_show, "Have lines and same file, should show for debug purposes"); +}; + +subtest filter_visible => sub { + my $root = $CLASS->new(verified => 1); + my $child1 = $CLASS->new(verified => 0, id => [HASH => 'a']); + my $child2 = $CLASS->new(verified => 1, id => [HASH => 'b']); + my $grand1 = $CLASS->new(verified => 0, id => [ARRAY => 0], children => []); + my $grand2 = $CLASS->new(verified => 0, id => [ARRAY => 1], children => []); + + $root->set_children([$child1, $child2]); + $child2->set_children([$grand1, $grand2]); + + is( + $root->filter_visible, + [ + ['{a}', $child1], + ['{b}[0]', $grand1], + ['{b}[1]', $grand2], + ], + "Got visible ones" + ); +}; + +subtest table_header => sub { + is($CLASS->table_header, [qw/PATH LNs GOT OP CHECK LNs/], "got header"); +}; + +subtest table_op => sub { + my $one = $CLASS->new(verified => 0); + is($one->table_op, '!exists', "no op if there is no check"); + + my $check = Test2::Compare::String->new(input => 'xyz'); + $one->set_chk($check); + $one->set_got('foo'); + is($one->table_op, 'eq', "got op"); + + $one->set_dne('anything'); + is($one->table_op, 'eq', "got op when dne is set to something other than 'got'"); + + $one->set_dne('got'); + is($one->table_op, '', "Called check->operator without args since dne is 'got'"); +}; + +subtest table_check_lines => sub { + my $one = $CLASS->new(verified => 0); + is($one->table_check_lines, '', 'no lines without a check'); + + my $check = Test2::Compare::String->new(input => 'xyz'); + $one->set_chk($check); + is($one->table_check_lines, '', 'check has no lines'); + + $check->set_lines([]); + is($one->table_check_lines, '', 'check has lines, but it is empty'); + + $check->set_lines([2, 4, 6]); + is($one->table_check_lines, '2, 4, 6', 'got lines'); +}; + +subtest table_got_lines => sub { + my $one = $CLASS->new(verified => 0); + is($one->table_got_lines, '', "no lines without a check"); + + my $check = Test2::Compare::String->new(input => 'xyz'); + $one->set_chk($check); + $one->set_dne('got'); + is($one->table_got_lines, '', "no lines when 'got' is dne"); + + $one->set_dne('anything'); + is($one->table_got_lines, '', "no lines found with other dne"); + + $one->set_dne(''); + is($one->table_got_lines, '', "no lines found by check"); + + my $c = mock 'Test2::Compare::Base' => ( + override => [ + got_lines => sub {(2, 4, 6)}, + ], + ); + + is($one->table_got_lines, '2, 4, 6', "got lines"); +}; + +subtest table_rows => sub { + my $one = $CLASS->new(verified => 0); + + # These are tested above, mocking here for simplicity + my $mock = mock $CLASS => ( + override => [ + filter_visible => sub { [['{foo}', $one], ['{bar}', $one]] }, + render_check => sub { 'CHECK!' }, + render_got => sub { 'GOT!' }, + table_op => sub { 'OP!' }, + table_check_lines => sub { 'CHECK LINES!' }, + table_got_lines => sub { 'GOT LINES!' }, + ], + ); + + my $rows = $one->table_rows; + $mock = undef; + + is( + $rows, + [ + ['{foo}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ['{bar}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ], + "got rows" + ); +}; + +subtest table => sub { + local $ENV{TS_MAX_DELTA} = 10; + my $rows; + my $mock = mock $CLASS => (override => [table_rows => sub { return $rows }]); + my $one = $CLASS->new(); + + $rows = [ + ['{foo}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ['{bar}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ['{baz}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ['{bat}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ]; + + def is => ( + [split /\n/, $one->table->as_string], + [ + '+-------+------------+------+-----+--------+--------------+', + '| PATH | LNs | GOT | OP | CHECK | LNs |', + '+-------+------------+------+-----+--------+--------------+', + '| {foo} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', + '| {bar} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', + '| {baz} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', + '| {bat} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', + '+-------+------------+------+-----+--------+--------------+', + ], + "Got expected table" + ); + + $rows = [ + ['{foo}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ['{bar}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ['{baz}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ['{bat}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], + ]; + + $ENV{TS_MAX_DELTA} = 2; + def is => ( + [split /\n/, $one->table->as_string], + [ + '+-------+------------+------+-----+--------+--------------+', + '| PATH | LNs | GOT | OP | CHECK | LNs |', + '+-------+------------+------+-----+--------+--------------+', + '| {foo} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', + '| {bar} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', + '+-------+------------+------+-----+--------+--------------+', + '************************************************************', + '* Stopped after 2 differences. *', + '* Set the TS_MAX_DELTA environment var to raise the limit. *', + '* Set it to 0 for no limit. *', + '************************************************************', + ], + "Got expected table and warning" + ); + + $ENV{TS_MAX_DELTA} = 25; + $rows = [ + ['{foo}', '', '', '', '', ''], + ['{bar}', '', '', '', '', ''], + ['{baz}', '', '', '', '', ''], + ['{bat}', '', '', '', '', ''], + ]; + + def is => ( + [split /\n/, $one->table->as_string], + [ + '+-------+-----+-------+', + '| PATH | GOT | CHECK |', + '+-------+-----+-------+', + '| {foo} | | |', + '| {bar} | | |', + '| {baz} | | |', + '| {bat} | | |', + '+-------+-----+-------+', + ], + "'GOT' and 'CHECK' never collapse" + ); + + $mock = undef; + delete $ENV{TS_MAX_DELTA}; + + do_def(); +}; + +subtest custom_columns => sub { + my $conv = Test2::Compare->can('strict_convert'); + my $comp = Test2::Compare->can('compare'); + + my $cmp = sub { + my $ctx = context(); + my $delta = $comp->(@_, $conv); + my $table = $delta->table; + $ctx->release; + return [split /\n/, $table->as_string]; + }; + + $CLASS->add_column('V' => sub { + my ($d) = @_; + return $d->verified ? '*' : ''; + }); + + my $table = $cmp->( + { foo => ['x', 'y'] }, + hash { + field foo => array { + item 'a'; + item 'b'; + }; + }, + ); + + like( + $table, + [ + qr/\Q+---+\E$/, + qr/\Q| V |\E$/, + qr/\Q+---+\E$/, + qr/\Q| * |\E$/, + qr/\Q| * |\E$/, + qr/\Q| |\E$/, + qr/\Q| |\E$/, + qr/\Q+---+\E$/, + DNE() + ], + "Got new column, it is last" + ); + + $table = $cmp->( + ['x', 'y'], + ['a', 'b'], + ); + + is($table->[1], mismatch qr/\Q| V |\E/, "Column not shown, it is empty"); + + is($CLASS->remove_column('V'), 1, "Removed the column"); + is($CLASS->remove_column('V'), 0, "No column to remove"); + + $CLASS->add_column( + 'V', + value => sub { + my ($d) = @_; + return $d->verified ? '*' : ''; + }, + alias => '?', + no_collapse => 1, + prefix => 1, + ); + + $table = $cmp->( + { foo => ['x', 'y'] }, + hash { + field foo => array { + item 'a'; + item 'b'; + }; + }, + ); + + like( + $table, + [ + qr/^\Q+---+\E/, + qr/^\Q| ? |\E/, + qr/^\Q+---+\E/, + qr/^\Q| * |\E/, + qr/^\Q| * |\E/, + qr/^\Q| |\E/, + qr/^\Q| |\E/, + qr/^\Q+---+\E/, + DNE() + ], + "Got new column, it is first" + ); + + $table = $cmp->( + ['x', 'y'], + ['a', 'b'], + ); + + like( + $table, + [ + qr/^\Q+---+\E/, + qr/^\Q| ? |\E/, + qr/^\Q+---+\E/, + qr/^\Q| |\E/, + qr/^\Q| |\E/, + qr/^\Q+---+\E/, + DNE() + ], + "Did not collapse" + ); + + is($CLASS->remove_column('V'), 1, "Removed the column"); + is($CLASS->remove_column('V'), 0, "No column to remove"); + + like( + dies { $CLASS->add_column }, + qr/Column name is required/, + "Column name is required" + ); + + like( + dies { $CLASS->add_column('FOO') }, + qr/You must specify a 'value' callback/, + "Need value callback" + ); + + like( + dies { $CLASS->add_column('FOO', 'foo') }, + qr/'value' callback must be a CODE reference/, + "Need value callback" + ); + + $CLASS->add_column('FOO' => sub { '' }); + like( + dies { $CLASS->add_column('FOO' => sub { '' }) }, + qr/Column 'FOO' is already defined/, + "No duplicates" + ); + + is($CLASS->remove_column('FOO'), 1, "Removed the column"); +}; + +subtest set_column_alias => sub { + $CLASS->set_column_alias(PATH => ' '); + is( + $CLASS->table_header, + [' ', qw/LNs GOT OP CHECK LNs/], + "hide column name" + ); + + $CLASS->set_column_alias(GLNs => 'Now This'); + is( + $CLASS->table_header, + [' ', 'Now This', qw/GOT OP CHECK LNs/], + "column name with spaces" + ); + + $CLASS->add_column('NEW' => sub { '' }); + $CLASS->set_column_alias(NEW => 'OLD'); + is( + $CLASS->table_header, + [' ', 'Now This', qw/GOT OP CHECK LNs OLD/], + "change added column name" + ); + + like( + dies { $CLASS->set_column_alias('OP') }, + qr/Missing alias/, + 'Missing alias' + ); + + like( + dies { $CLASS->set_column_alias(DNE => 'NOPE') }, + qr/Tried to alias a non-existent column/, + 'Needs existing column name' + ); +}; + +subtest overload => sub { + no warnings 'once'; + { + package Overload::Foo; + use overload + '""' => sub { 'FOO' }, + '0+' => sub { 42 }; + + package Overload::Bar; + use overload + '""' => sub { 'BAR' }, + '0+' => sub { 99 }; + } + + my $foo = bless \*FOO, 'Overload::Foo'; + my $bar = bless \*BAR, 'Overload::Bar'; + + is("$foo", "FOO", "overloaded string form FOO"); + is("$bar", "BAR", "overloaded string form BAR"); + is(int($foo), 42, "overloaded number form FOO"); + is(int($bar), 99, "overloaded number form BAR"); + + my $conv = Test2::Compare->can('strict_convert'); + my $comp = Test2::Compare->can('compare'); + my $cmp = sub { + my $ctx = context(); + my $delta = $comp->(@_, $conv); + my $table = $delta->table; + $ctx->release; + return [split /\n/, $table->as_string]; + }; + + my $table = $cmp->($foo, $bar); + + # On some systems the memory address is long enough to cause this to wrap. + my @checks; + if (@$table == 5) { + @checks = ( + qr/^\| Overload::Foo=GLOB\(.+\)\s+\| ==\s+\| Overload::Bar=GLOB\(.+\)\s+\|$/, + ); + } + else { + @checks = ( + qr/^\| Overload::Foo=GLOB\(.+\s+\| ==\s+\| Overload::Bar=GLOB\(.+\s+\|$/, + qr/^\| .*\)\s+\| \s+\| .*\)\s+\|$/, + ); + } + + like( + $table, + [ + T(), # Border + T(), # Header + T(), # Border + @checks, + T(), # Border + DNE(), # END + ], + "Showed type+mem address, despire overloading" + ); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Event.t b/cpan/Test2-Suite/t/modules/Compare/Event.t new file mode 100644 index 000000000000..e529efdcd086 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Event.t @@ -0,0 +1,16 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Event'; + +my $one = $CLASS->new(etype => 'Ok'); +is($one->name, '', "got name"); +is($one->meta_class, 'Test2::Compare::EventMeta', "correct meta class"); +is($one->object_base, 'Test2::Event', "Event is the base class"); + +my $trace = Test2::Util::Trace->new(frame => ['Foo', 'foo.t', 42, 'foo']); +my $Ok = Test2::Event::Ok->new(trace => $trace, pass => 1); + +is($one->got_lines(), undef, "no lines"); +is($one->got_lines('xxx'), undef, "no lines"); +is($one->got_lines(bless {}, 'XXX'), undef, "no lines"); +is($one->got_lines($Ok), 42, "got the correct line"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/EventMeta.t b/cpan/Test2-Suite/t/modules/Compare/EventMeta.t new file mode 100644 index 000000000000..09b2e4946596 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/EventMeta.t @@ -0,0 +1,18 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::EventMeta'; + +use Test2::Util qw/get_tid/; + +my $one = $CLASS->new(); + +my $trace = Test2::Util::Trace->new(frame => ['Foo', 'foo.t', 42, 'foo']); +my $Ok = Test2::Event::Ok->new(trace => $trace, pass => 1); + +is($one->get_prop_file($Ok), 'foo.t', "file"); +is($one->get_prop_line($Ok), 42, "line"); +is($one->get_prop_package($Ok), 'Foo', "package"); +is($one->get_prop_subname($Ok), 'foo', "subname"); +is($one->get_prop_debug($Ok), 'at foo.t line 42', "trace"); +is($one->get_prop_pid($Ok), $$, "pid"); +is($one->get_prop_tid($Ok), get_tid, "tid"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Float.t b/cpan/Test2-Suite/t/modules/Compare/Float.t new file mode 100644 index 000000000000..82629409199d --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Float.t @@ -0,0 +1,181 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Float'; + +my $num = $CLASS->new(input => '22.0', tolerance => .001); +my $neg_num = $CLASS->new(input => -22, tolerance => .001); +my $untrue = $CLASS->new(input => 0); +my $pre_num = $CLASS->new(input => '22.0', precision => 3); + +isa_ok($num, $CLASS, 'Test2::Compare::Base'); +isa_ok($untrue, $CLASS, 'Test2::Compare::Base'); + +subtest tolerance => sub { + is($num->tolerance, 0.001, "got expected tolerance for number"); + is($untrue->tolerance, 1e-08, "got default tolerance for 0"); +}; + +subtest name => sub { + is($num->name, '22.0 +/- ' . $num->tolerance, "got expected name for number"); + is($untrue->name, '0 +/- ' . $untrue->tolerance, "got expected name for 0"); + # Note: string length of mantissa varies by perl install, e.g. 1e-08 vs 1e-008 + + is($pre_num->name, '22.000', "got expected 3 digits of precision in name for 22.0, precision=5"); + is($CLASS->new(input => '100.123456789012345', precision => 10)->name, + '100.1234567890', + 'got expected precision in name at precision=10'); + is($CLASS->new(input => '100.123456789012345', precision => 15)->name, + sprintf('%.*f', 15, '100.123456789012345'), + 'got expected precision in name at precision=15'); # likely not 100.123456789012345! + is($CLASS->new(input => '100.123456789012345', precision => 20)->name, + sprintf('%.*f', 20, '100.123456789012345'), + 'got expected precision in name at precision=20'); +}; + +subtest operator => sub { + is($num->operator(), '', "no operator for number + nothing"); + is($num->operator(undef), '', "no operator for number + undef"); + is($num->operator(1), '==', "== operator for number + number"); + + is($untrue->operator(), '', "no operator for 0 + nothing"); + is($untrue->operator(undef), '', "no operator for 0 + undef"); + is($untrue->operator(1), '==', "== operator for 0 + number"); + + is($pre_num->operator(), '', "no operator for precision number + nothing"); + is($pre_num->operator(undef), '', "no operator for precision number + undef"); + is($pre_num->operator(1), 'eq', "eq operator for precision number + number"); +}; + +subtest verify => sub { + ok(!$num->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$num->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$num->verify(exists => 1, got => undef), 'looking for a number, not undef'); + ok(!$num->verify(exists => 1, got => 'x'), 'not looking for a string'); + ok(!$num->verify(exists => 1, got => 1), 'wrong number'); + ok($num->verify(exists => 1, got => 22), '22.0 == 22'); + ok($num->verify(exists => 1, got => '22.0'), 'exact match with decimal'); + + ok(!$untrue->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$untrue->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$untrue->verify(exists => 1, got => undef), 'undef is not 0 for this test'); + ok(!$untrue->verify(exists => 1, got => 'x'), 'x is not 0'); + ok(!$untrue->verify(exists => 1, got => 1), '1 is not 0'); + ok(!$untrue->verify(exists => 1, got => ''), '"" is not 0'); + ok(!$untrue->verify(exists => 1, got => ' '), '" " is not 0'); + ok($untrue->verify(exists => 1, got => 0), 'got 0'); + ok($untrue->verify(exists => 1, got => '0.0'), '0.0 == 0'); + ok($untrue->verify(exists => 1, got => '-0.0'), '-0.0 == 0'); +}; + +subtest verify_float_tolerance => sub { + ok($num->verify(exists => 1, got => "22.0"), '22.0 == 22 +/- .001'); + ok($num->verify(exists => 1, got => "22.0009"), '22.0009 == 22 +/- .001'); + ok($num->verify(exists => 1, got => "21.9991"), '21.9991 == 22 +/- .001'); + ok(!$num->verify(exists => 1, got => "22.0011"), '22.0009 != 22 +/- .001'); + ok(!$num->verify(exists => 1, got => "21.9989"), '21.9989 != 22 +/- .001'); + ok(!$num->verify(exists => 1, got => "23"), '23 != 22 +/- .001'); + + ok($num->verify(exists => 1, got => 22.0), '22.0 == 22 +/- .001'); + ok($num->verify(exists => 1, got => 22.0009), '22.0009 == 22 +/- .001'); + ok($num->verify(exists => 1, got => 21.9991), '21.9991 == 22 +/- .001'); + ok(!$num->verify(exists => 1, got => 22.0011), '22.0009 != 22 +/- .001'); + ok(!$num->verify(exists => 1, got => 21.9989), '21.9989 != 22 +/- .001'); + ok(!$num->verify(exists => 1, got => 23), '23 != 22 +/- .001'); + + ok($neg_num->verify(exists => 1, got => -22.0), '-22.0 == -22 +/- .001'); + ok($neg_num->verify(exists => 1, got => -22.0009), '-22.0009 == -22 +/- .001'); + ok($neg_num->verify(exists => 1, got => -21.9991), '-21.9991 == -22 +/- .001'); + ok(!$neg_num->verify(exists => 1, got => -22.0011), '-22.0009 != -22 +/- .001'); + ok(!$neg_num->verify(exists => 1, got => -21.9989), '-21.9989 != -22 +/- .001'); + ok(!$neg_num->verify(exists => 1, got => -23), '-23 != -22 +/- .001'); +}; +subtest verify_float_precision => sub { + ok($pre_num->verify(exists => 1, got => "22.0"), '22.0 == 22.000'); + ok($pre_num->verify(exists => 1, got => "22.0001"), '22.0001 == 22.000'); + ok($pre_num->verify(exists => 1, got => "21.9999"), '21.9999 == 22.000'); + ok(!$pre_num->verify(exists => 1, got => "22.0011"), '22.0011 != 22.000'); + ok(!$pre_num->verify(exists => 1, got => "21.9989"), '21.9989 != 22.000'); + ok(!$pre_num->verify(exists => 1, got => "23"), '23 != 22.000'); + + ok($pre_num->verify(exists => 1, got => 22.0), '22.0 == 22.000'); + ok($pre_num->verify(exists => 1, got => 22.00049), '22.00049 == 22.000'); + ok(!$pre_num->verify(exists => 1, got => 22.00051), '22.00051 != 22.000'); + ok($pre_num->verify(exists => 1, got => 21.99951), '21.99951 == 22.000'); + ok(!$pre_num->verify(exists => 1, got => 22.0009), '22.0009 != 22.000'); + ok(!$pre_num->verify(exists => 1, got => 21.9989), '21.9989 != 22.000'); + ok(!$pre_num->verify(exists => 1, got => 23), '23 != 22.000'); + + ok($neg_num->verify(exists => 1, got => -22.0), '-22.0 == -22.000'); + ok($neg_num->verify(exists => 1, got => -22.0009), '-22.0009 == -22.000'); + ok($neg_num->verify(exists => 1, got => -21.9991), '-21.9991 == -22.000'); + ok(!$neg_num->verify(exists => 1, got => -22.0011), '-22.0009 != -22.000'); + ok(!$neg_num->verify(exists => 1, got => -21.9989), '-21.9989 != -22.000'); + ok(!$neg_num->verify(exists => 1, got => -23), '-23 != -22.000'); +}; + +subtest rounding_tolerance => sub { + my $round_08 = $CLASS->new(input => '60.48'); + my $round_13 = $CLASS->new(input => '60.48', tolerance => 1e-13); + my $round_14 = $CLASS->new(input => '60.48', tolerance => 1e-14); + + ok($round_08->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_08->name . " - inside tolerance"); + ok($round_13->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_13->name . " - inside tolerance"); + ok($round_14->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_14->name . " - inside tolerance"); + + ok($round_08->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_08->name . " - inside tolerance"); + ok($round_13->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_13->name . " - inside tolerance"); + + todo 'broken on some platforms' => sub { + ok(!$round_14->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 != ' . $round_14->name . " - outside tolerance"); + }; +}; + +subtest rounding_precision => sub { + my $round_08 = $CLASS->new(input => '60.48', precision => 8 ); + my $round_13 = $CLASS->new(input => '60.48', precision => 13); + my $round_14 = $CLASS->new(input => '60.48', precision => 14); + + ok($round_08->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_08->name . " - inside precision"); + ok($round_13->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_13->name . " - inside precision"); + ok($round_14->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_14->name . " - inside precision"); + + ok($round_08->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_08->name . " - inside precision"); + ok($round_13->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_13->name . " - inside precision"); + + # unlike TOLERANCE, this should work on 32 and 64 bit platforms. + ok($round_14->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 != ' . $round_14->name . " - outside precision"); +}; + +like( + dies { $CLASS->new() }, + qr/input must be defined for 'Float' check/, + "Cannot use undef as a number" +); + +like( + dies { $CLASS->new(input => '') }, + qr/input must be a number for 'Float' check/, + "Cannot use empty string as a number" +); + +like( + dies { $CLASS->new(input => ' ') }, + qr/input must be a number for 'Float' check/, + "Cannot use whitespace string as a number" +); + +like( + dies { $CLASS->new(input => 1.234, precision => 5, tolerance => .001) }, + qr/can't set both tolerance and precision/, + "Cannot use both precision and tolerance" +); +like( + dies { $CLASS->new(input => 1.234, precision => .05) }, + qr/precision must be an integer/, + "precision can't be fractional" +); +like( + dies { $CLASS->new(input => 1.234, precision => -2) }, + qr/precision must be an integer/, + "precision can't be negative" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Hash.t b/cpan/Test2-Suite/t/modules/Compare/Hash.t new file mode 100644 index 000000000000..12d1561c0800 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Hash.t @@ -0,0 +1,215 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Hash'; + +use lib 't/lib'; + +subtest simple => sub { + my $one = $CLASS->new(); + isa_ok($one, $CLASS, 'Test2::Compare::Base'); + + is($one->name, '', "name is "); +}; + +subtest verify => sub { + my $one = $CLASS->new(); + + ok(!$one->verify(exists => 0), "nothing to verify"); + ok(!$one->verify(exists => 1, got => undef), "undef is not a hashref"); + ok(!$one->verify(exists => 1, got => 1), "1 is not a hashref"); + ok(!$one->verify(exists => 1, got => []), "An arrayref is not a hashref"); + + ok($one->verify(exists => 1, got => {}), "got a hashref"); +}; + +subtest init => sub { + my $one = $CLASS->new(); + ok( defined $one, "args are not required"); + is($one->items, {}, "got the items hash"); + is($one->order, [], "got order array"); + + $one = $CLASS->new(inref => { a => 1, b => 2 }); + is($one->items, {a => 1, b => 2}, "got the items hash"); + is($one->order, ['a', 'b'], "generated order (ascii sort)"); + + $one = $CLASS->new(items => { a => 1, b => 2 }, order => [ 'b', 'a' ]); + is($one->items, {a => 1, b => 2}, "got the items hash"); + is($one->order, ['b', 'a'], "got specified order"); + + $one = $CLASS->new(items => { a => 1, b => 2 }); + is($one->items, {a => 1, b => 2}, "got the items hash"); + is($one->order, ['a', 'b'], "generated order (ascii sort)"); + + like( + dies { $CLASS->new(inref => {a => 1}, items => {a => 1}) }, + qr/Cannot specify both 'inref' and 'items'/, + "inref and items are exclusive" + ); + + like( + dies { $CLASS->new(inref => {a => 1}, order => ['a']) }, + qr/Cannot specify both 'inref' and 'order'/, + "inref and order are exclusive" + ); + + like( + dies { $CLASS->new(items => { a => 1, b => 2, c => 3 }, order => ['a']) }, + qr/Keys are missing from the 'order' array: b, c/, + "Missing fields in order" + ); +}; + +subtest add_field => sub { + my $one = $CLASS->new(); + + $one->add_field(a => 1); + $one->add_field(c => 3); + $one->add_field(b => 2); + + like( + dies { $one->add_field(undef, 'x') }, + qr/field name is required/, + "Must specify a field name" + ); + + like( + dies { $one->add_field(a => 1) }, + qr/field 'a' has already been specified/, + "Cannot add field twice" + ); + + is($one->items, { a => 1, b => 2, c => 3 }, "added items"); + is($one->order, [ 'a', 'c', 'b' ], "order preserved"); +}; + +subtest deltas => sub { + my $convert = Test2::Compare->can('strict_convert'); + + my %params = (exists => 1, convert => $convert, seen => {}); + + my $one = $CLASS->new(inref => {a => 1, b => 2, c => 3, x => DNE()}); + + is( + [$one->deltas(got => {a => 1, b => 2, c => 3}, %params)], + [], + "No deltas, perfect match" + ); + + is( + [$one->deltas(got => {a => 1, b => 2, c => 3, e => 4, f => 5}, %params)], + [], + "No deltas, extra items are ok" + ); + + $one->set_ending(1); + is( + [$one->deltas(got => {a => 1, b => 2, c => 3, e => 4, f => 5}, %params)], + [ + { + dne => 'check', + verified => F(), + id => [HASH => 'e'], + got => 4, + chk => F(), + }, + { + dne => 'check', + verified => F(), + id => [HASH => 'f'], + got => 5, + chk => F(), + }, + ], + "Extra items are no longer ok, problem" + ); + + is( + [$one->deltas(got => {a => 1}, %params)], + [ + { + children => [], + dne => 'got', + verified => F(), + id => [HASH => 'b'], + got => F(), + chk => T(), + }, + { + children => [], + dne => 'got', + verified => F(), + id => [HASH => 'c'], + got => F(), + chk => T(), + }, + ], + "Missing items" + ); + + is( + [$one->deltas(got => {a => 1, b => 1, c => 1}, %params)], + [ + { + children => [], + verified => F(), + id => [HASH => 'b'], + got => 1, + chk => T(), + }, + { + children => [], + verified => F(), + id => [HASH => 'c'], + got => 1, + chk => T(), + }, + ], + "Items are wrong" + ); + + like( + [$one->deltas(got => {a => 1, b => 2, c => 3, x => 'oops'}, %params)], + [ + { + verified => F(), + id => [HASH => 'x'], + got => 'oops', + check => DNE(), + }, + ], + "Items are wrong" + ); + +}; + +subtest add_prop => sub { + my $one = $CLASS->new(); + + ok(!$one->meta, "no meta yet"); + $one->add_prop('size' => 1); + isa_ok($one->meta, 'Test2::Compare::Meta'); + is(@{$one->meta->items}, 1, "1 item"); + + $one->add_prop('reftype' => 'HASH'); + is(@{$one->meta->items}, 2, "2 items"); +}; + +{ + package Foo::Hash; + + use base 'MyTest::Target'; + + sub new { + my $class = shift; + bless { @_ } , $class; + } +} + +subtest objects_with_hashes => sub { + + my $o1 = Foo::Hash->new( b => { foo => 2 } ) ; + my $o2 = Foo::Hash->new( b => { foo => 2 } ) ; + + is ( $o1, $o2, "same" ); +}; + + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Isa.t b/cpan/Test2-Suite/t/modules/Compare/Isa.t new file mode 100644 index 000000000000..7a52174b7c11 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Isa.t @@ -0,0 +1,63 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Isa'; + +{ + package Foo; + + package Foo::Bar; + our @ISA = 'Foo'; + + package Baz; +} + +my $isa_foo = $CLASS->new(input => 'Foo'); +my $isa_foo_bar = $CLASS->new(input => 'Foo::Bar'); +my $not_isa_foo_bar = $CLASS->new(input => 'Foo::Bar', negate => 1); + +isa_ok($_, $CLASS, 'Test2::Compare::Base') for $isa_foo, $isa_foo_bar, $not_isa_foo_bar; + +subtest name => sub { + is($isa_foo->name, 'Foo', "got expected name"); + is($isa_foo_bar->name, 'Foo::Bar', "got expected name"); + is($not_isa_foo_bar->name, 'Foo::Bar', "got expected name"); +}; + +subtest operator => sub { + is($isa_foo->operator, 'isa', "got expected operator"); + is($isa_foo_bar->operator, 'isa', "got expected operator"); + is($not_isa_foo_bar->operator, '!isa', "got expected operator"); +}; + +subtest verify => sub { + my $foo = bless {}, 'Foo'; + my $foo_bar = bless {}, 'Foo::Bar'; + my $baz = bless {}, 'Baz'; + + ok(!$isa_foo->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$isa_foo->verify(exists => 1, got => undef), 'undef is not an instance of Foo'); + ok(!$isa_foo->verify(exists => 1, got => 42), '42 is not an instance of Foo'); + ok($isa_foo->verify(exists => 1, got => $foo), '$foo is an instance of Foo'); + ok($isa_foo->verify(exists => 1, got => $foo_bar), '$foo_bar is an instance of Foo'); + ok(!$isa_foo->verify(exists => 1, got => $baz), '$baz is not an instance of Foo'); + + ok(!$isa_foo_bar->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$isa_foo_bar->verify(exists => 1, got => undef), 'undef is not an instance of Foo::Bar'); + ok(!$isa_foo_bar->verify(exists => 1, got => 42), '42 is not an instance of Foo::Bar'); + ok(!$isa_foo_bar->verify(exists => 1, got => $foo), '$foo is not an instance of Foo::Bar'); + ok($isa_foo_bar->verify(exists => 1, got => $foo_bar), '$foo_bar is an instance of Foo::Bar'); + ok(!$isa_foo_bar->verify(exists => 1, got => $baz), '$baz is not an instance of Foo::Bar'); + + ok(!$not_isa_foo_bar->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok($not_isa_foo_bar->verify(exists => 1, got => undef), 'undef is not an instance of Foo::Bar'); + ok($not_isa_foo_bar->verify(exists => 1, got => 42), '42 is not an instance of Foo::Bar'); + ok($not_isa_foo_bar->verify(exists => 1, got => $foo), '$foo is not an instance of Foo::Bar'); + ok(!$not_isa_foo_bar->verify(exists => 1, got => $foo_bar), '$foo_bar is an instance of Foo::Bar'); + ok($not_isa_foo_bar->verify(exists => 1, got => $baz), '$baz is not an instance of Foo::Bar'); +}; + +like( + dies { $CLASS->new() }, + qr/input must be defined for 'Isa' check/, + "Cannot use undef as a class name" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Meta.t b/cpan/Test2-Suite/t/modules/Compare/Meta.t new file mode 100644 index 000000000000..68050b1c18bb --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Meta.t @@ -0,0 +1,90 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Meta'; + +local *convert = Test2::Compare->can('strict_convert'); + +subtest simple => sub { + my $one = $CLASS->new(); + isa_ok($one, $CLASS, 'Test2::Compare::Base'); + is($one->items, [], "generated an empty items array"); + is($one->name, '', "sane name"); + is($one->verify(exists => 0), 0, "Does not verify for non-existant values"); + is($one->verify(exists => 1), 1, "always verifies for existing values"); + ok(defined $CLASS->new(items => []), "Can provide items"); +}; + +subtest add_prop => sub { + my $one = $CLASS->new(); + + like( + dies { $one->add_prop(undef, convert(1)) }, + qr/prop name is required/, + "property name is required" + ); + + like( + dies { $one->add_prop('fake' => convert(1)) }, + qr/'fake' is not a known property/, + "Must use valid property" + ); + + like( + dies { $one->add_prop('blessed') }, + qr/check is required/, + "Must use valid property" + ); + + ok($one->add_prop('blessed' => convert('xxx')), "normal"); +}; + +{ + package FooBase; + + package Foo; + our @ISA = 'FooBase'; +} + +subtest deltas => sub { + my $one = $CLASS->new(); + + my $it = bless {a => 1, b => 2, c => 3}, 'Foo'; + + $one->add_prop('blessed' => 'Foo'); + $one->add_prop('reftype' => 'HASH'); + $one->add_prop('isa' => 'FooBase'); + $one->add_prop('this' => exact_ref($it)); + $one->add_prop('size' => 3); + + is( + [$one->deltas(got => $it, convert => \&convert, seen => {})], + [], + "Everything matches" + ); + + my $not_it = bless ['a'], 'Bar'; + + like( + [$one->deltas(got => $not_it, convert => \&convert, seen => {})], + [ + { verified => F(), got => 'Bar' }, + { verified => F(), got => 'ARRAY' }, + { verified => F(), got => $not_it }, + { verified => F(), got => $not_it }, + { verified => F(), got => 1 }, + ], + "Nothing matches" + ); + + like( + [$one->deltas(got => 'a', convert => \&convert, seen => {})], + [ + { verified => F(), got => undef }, + { verified => F(), got => undef }, + { verified => F(), got => 'a' }, + { verified => F(), got => 'a' }, + { verified => F(), got => undef }, + ], + "Nothing matches, wrong everything" + ); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Number.t b/cpan/Test2-Suite/t/modules/Compare/Number.t new file mode 100644 index 000000000000..89c03ac0cef7 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Number.t @@ -0,0 +1,73 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Number'; + +my $num = $CLASS->new(input => '22.0'); +my $untrue = $CLASS->new(input => 0); + +isa_ok($num, $CLASS, 'Test2::Compare::Base'); +isa_ok($untrue, $CLASS, 'Test2::Compare::Base'); + +subtest name => sub { + is($num->name, '22.0', "got expected name for number"); + is($untrue->name, '0', "got expected name for 0"); +}; + +subtest operator => sub { + is($num->operator(), '', "no operator for number + nothing"); + is($num->operator(undef), '', "no operator for number + undef"); + is($num->operator(1), '==', "== operator for number + number"); + + is($untrue->operator(), '', "no operator for 0 + nothing"); + is($untrue->operator(undef), '', "no operator for 0 + undef"); + is($untrue->operator(1), '==', "== operator for 0 + number"); +}; + +subtest verify => sub { + ok(!$num->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$num->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$num->verify(exists => 1, got => undef), 'looking for a number, not undef'); + ok(!$num->verify(exists => 1, got => 'x'), 'not looking for a string'); + ok(!$num->verify(exists => 1, got => 1), 'wrong number'); + ok($num->verify(exists => 1, got => 22), '22.0 == 22'); + ok($num->verify(exists => 1, got => '22.0'), 'exact match with decimal'); + + ok(!$untrue->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$untrue->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$untrue->verify(exists => 1, got => undef), 'undef is not 0 for this test'); + ok(!$untrue->verify(exists => 1, got => 'x'), 'x is not 0'); + ok(!$untrue->verify(exists => 1, got => 1), '1 is not 0'); + ok(!$untrue->verify(exists => 1, got => ''), '"" is not 0'); + ok(!$untrue->verify(exists => 1, got => ' '), '" " is not 0'); + ok($untrue->verify(exists => 1, got => 0), 'got 0'); + ok($untrue->verify(exists => 1, got => '0.0'), '0.0 == 0'); + ok($untrue->verify(exists => 1, got => '-0.0'), '-0.0 == 0'); +}; + +subtest rounding => sub { + my $round = $CLASS->new(input => '60.48'); + ok($round->verify(exists => 1, got => 60.48), '60.48 == 60.48'); + + { + my $todo = todo "floating point comparison representation error"; + ok($round->verify(exists => 1, got => 125 - 64.52), '60.48 == 125 - 64.52'); + } +}; + +like( + dies { $CLASS->new() }, + qr/input must be defined for 'Number' check/, + "Cannot use undef as a number" +); + +like( + dies { $CLASS->new(input => '') }, + qr/input must be a number for 'Number' check/, + "Cannot use empty string as a number" +); + +like( + dies { $CLASS->new(input => ' ') }, + qr/input must be a number for 'Number' check/, + "Cannot use whitespace string as a number" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Object.t b/cpan/Test2-Suite/t/modules/Compare/Object.t new file mode 100644 index 000000000000..0c8703ff328b --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Object.t @@ -0,0 +1,285 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Object'; + +subtest simple => sub { + my $one = $CLASS->new; + isa_ok($one, $CLASS, 'Test2::Compare::Base'); + + is($one->calls, [], "got calls arrayref for free"); + + is($one->name, '', "Got name"); + + is($one->meta_class, 'Test2::Compare::Meta', "Correct metaclass"); + + is($one->object_base, 'UNIVERSAL', "Correct object base"); + + ok(defined $CLASS->new(calls => []), "Can specify a calls array") +}; + +subtest verify => sub { + my $one = $CLASS->new; + + ok(!$one->verify(exists => 0), "nothing to verify"); + ok(!$one->verify(exists => 1, got => 1), "not a ref"); + ok(!$one->verify(exists => 1, got => {}), "not blessed"); + + ok($one->verify(exists => 1, got => bless({}, 'Foo')), "Blessed"); + + no warnings 'once'; + local *Foo::isa = sub { 0 }; + ok(!$one->verify(exists => 1, got => bless({}, 'Foo')), "not a 'UNIVERSAL' (pretend)"); +}; + +subtest add_prop => sub { + my $one = $CLASS->new(); + + ok(!$one->meta, "no meta yet"); + $one->add_prop('blessed' => 'Foo'); + isa_ok($one->meta, 'Test2::Compare::Meta'); + is(@{$one->meta->items}, 1, "1 item"); + + $one->add_prop('reftype' => 'HASH'); + is(@{$one->meta->items}, 2, "2 items"); +}; + +subtest add_field => sub { + my $one = $CLASS->new(); + + ok(!$one->refcheck, "no refcheck yet"); + $one->add_field(foo => 1); + isa_ok($one->refcheck, 'Test2::Compare::Hash'); + is(@{$one->refcheck->order}, 1, "1 item"); + + $one->add_field(bar => 1); + is(@{$one->refcheck->order}, 2, "2 items"); + + $one = $CLASS->new(); + $one->add_item(0 => 'foo'); + like( + dies { $one->add_field(foo => 1) }, + qr/Underlying reference does not have fields/, + "Cannot add fields to a non-hash refcheck" + ); +}; + +subtest add_item => sub { + my $one = $CLASS->new(); + + ok(!$one->refcheck, "no refcheck yet"); + $one->add_item(0 => 'foo'); + isa_ok($one->refcheck, 'Test2::Compare::Array'); + is(@{$one->refcheck->order}, 1, "1 item"); + + $one->add_item(1 => 'bar'); + is(@{$one->refcheck->order}, 2, "2 items"); + + $one = $CLASS->new(); + $one->add_field('foo' => 1); + like( + dies { $one->add_item(0 => 'foo') }, + qr/Underlying reference does not have items/, + "Cannot add items to a non-array refcheck" + ); +}; + +subtest add_call => sub { + my $one = $CLASS->new; + + my $code = sub { 1 }; + + $one->add_call(foo => 'FOO'); + $one->add_call($code, 1); + $one->add_call($code, 1, 'custom'); + $one->add_call($code, 1, 'custom', 'list'); + + is( + $one->calls, + [ + ['foo', 'FOO', 'foo', 'scalar'], + [$code, 1, '\&CODE', 'scalar'], + [$code, 1, 'custom', 'scalar'], + [$code, 1, 'custom', 'list'], + ], + "Added all 4 calls" + ); +}; + +{ + package Foo; + + package Foo::Bar; + our @ISA = 'Foo'; + + sub foo { 'foo' } + sub baz { 'baz' } + sub one { 1 } + sub many { return (1,2,3,4) } + sub args { shift; +{@_} } + + package Fake::Fake; + + sub foo { 'xxx' } + sub one { 2 } + sub args { shift; +[@_] } +} + +subtest deltas => sub { + my $convert = Test2::Compare->can('strict_convert'); + + my $good = bless { a => 1 }, 'Foo::Bar'; + my $bad = bless [ 'a', 1 ], 'Fake::Fake'; + + my $one = $CLASS->new; + $one->add_field(a => 1); + $one->add_prop(blessed => 'Foo::Bar'); + $one->add_prop(isa => 'Foo'); + + $one->add_call(sub { + my $self = shift; + die "XXX" unless $self->isa('Foo::Bar'); + 'live'; + }, 'live', 'maybe_throw'); + + $one->add_call('foo' => 'foo'); + $one->add_call('baz' => 'baz'); + $one->add_call('one' => 1); + $one->add_call('many' => [1,2,3,4],undef,'list'); + $one->add_call('many' => {1=>2,3=>4},undef,'hash'); + $one->add_call([args => 1,2] => {1=>2}); + + is( + [$one->deltas(exists => 1, got => $good, convert => $convert, seen => {})], + [], + "Nothing failed" + ); + + like( + [$one->deltas(got => $bad, convert => $convert, seen => {})], + [ + { + chk => T(), + got => 'Fake::Fake', + id => ['META' => 'blessed'], + }, + { + chk => T(), + got => T(), + id => ['META' => 'isa'], + }, + { + chk => T(), + got => undef, + id => [METHOD => 'maybe_throw'], + exception => qr/XXX/, + }, + { + chk => T(), + got => 'xxx', + id => [METHOD => 'foo'], + }, + { + chk => T(), + dne => 'got', + got => undef, + id => [METHOD => 'baz'], + }, + { + chk => T(), + got => 2, + id => [METHOD => 'one'], + }, + { + chk => T(), + dne => 'got', + got => undef, + id => [METHOD => 'many'], + }, + { + chk => T(), + dne => 'got', + got => undef, + id => [METHOD => 'many'], + }, + { + chk => T(), + got => [1,2], + id => [METHOD => 'args'], + }, + { + chk => T(), + got => [], + id => [META => 'Object Ref'], + }, + ], + "Everything failed" + ); + + # This is critical, there were a couple bugs only seen when wrapped in + # 'run' instead of directly calling 'deltas' + like( + [$one->run(id => undef, got => $bad, convert => $convert, seen => {})], + [ + { + verified => 1, + children => [ + { + chk => T(), + got => 'Fake::Fake', + id => ['META' => 'blessed'], + }, + { + chk => T(), + got => T(), + id => ['META' => 'isa'], + }, + { + chk => T(), + got => undef, + id => [METHOD => 'maybe_throw'], + exception => qr/XXX/, + }, + { + chk => T(), + got => 'xxx', + id => [METHOD => 'foo'], + }, + { + chk => T(), + dne => 'got', + got => undef, + id => [METHOD => 'baz'], + }, + { + chk => T(), + got => 2, + id => [METHOD => 'one'], + }, + { + chk => T(), + dne => 'got', + got => undef, + id => [METHOD => 'many'], + }, + { + chk => T(), + dne => 'got', + got => undef, + id => [METHOD => 'many'], + }, + { + chk => T(), + got => [1,2], + id => [METHOD => 'args'], + }, + { + chk => T(), + got => [], + id => [META => 'Object Ref'], + }, + ], + }, + ], + "Everything failed, check when wrapped" + ); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/OrderedSubset.t b/cpan/Test2-Suite/t/modules/Compare/OrderedSubset.t new file mode 100644 index 000000000000..f17c240a4596 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/OrderedSubset.t @@ -0,0 +1,115 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::OrderedSubset'; + +use lib 't/lib'; + +isa_ok($CLASS, 'Test2::Compare::Base'); +is($CLASS->name, '', "got name"); + +subtest construction => sub { + my $one = $CLASS->new(); + isa_ok($one, $CLASS); + is($one->items, [], "created items as an array"); + + $one = $CLASS->new(items => [qw/a b/]); + is($one->items, [qw/a b/], "used items as specified"); + + $one = $CLASS->new(inref => ['a', 'b']); + is($one->items, [qw/a b/], "Generated items"); + + like( + dies { $CLASS->new(inref => { 1 => 'a' }) }, + qr/'inref' must be an array reference, got 'HASH\(.+\)'/, + "inref must be an array" + ); +}; + +subtest verify => sub { + my $one = $CLASS->new; + + is($one->verify(exists => 0), 0, "did not get anything"); + is($one->verify(exists => 1, got => undef), 0, "undef is not an array"); + is($one->verify(exists => 1, got => 0), 0, "0 is not an array"); + is($one->verify(exists => 1, got => 1), 0, "1 is not an array"); + is($one->verify(exists => 1, got => 'string'), 0, "'string' is not an array"); + is($one->verify(exists => 1, got => {}), 0, "a hash is not an array"); + is($one->verify(exists => 1, got => []), 1, "an array is an array"); +}; + +subtest add_item => sub { + my $one = $CLASS->new(); + + $one->add_item('a'); + $one->add_item(1 => 'b'); + $one->add_item(3 => 'd'); + + $one->add_item(8 => 'x'); + $one->add_item('y'); + + is( + $one->items, + [ 'a', 'b', 'd', 'x', 'y' ], + "Expected items" + ); +}; + +subtest deltas => sub { + my $conv = Test2::Compare->can('strict_convert'); + + my %params = (exists => 1, convert => $conv, seen => {}); + + my $inref = ['a', 'b']; + my $one = $CLASS->new(inref => $inref); + + like( + [$one->deltas(%params, got => ['a', 'b'])], + [], + "No delta, no diff" + ); + + like( + [$one->deltas(%params, got => ['a'])], + [ + { + dne => 'got', + id => [ARRAY => '?'], + } + ], + "Got the delta for the missing value" + ); + + like( + [$one->deltas(%params, got => ['a', 'a'])], + [ + { + dne => 'got', + id => [ARRAY => '?'], + } + ], + "Got the delta for the incorrect value" + ); + + like( + [$one->deltas(%params, got => ['a', 'b', 'a', 'a'])], + [], + "No delta, not checking ending" + ); +}; + +{ + package Foo::OO; + + use base 'MyTest::Target'; + + sub new { + my $class = shift; + bless [ @_ ] , $class; + } +} + +subtest object_as_arrays => sub { + my $o1 = Foo::OO->new( 'b') ; + + is ( $o1 , subset{ item 'b' }, "same" ); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Pattern.t b/cpan/Test2-Suite/t/modules/Compare/Pattern.t new file mode 100644 index 000000000000..cf8436deedcd --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Pattern.t @@ -0,0 +1,30 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Pattern'; + +my $one = $CLASS->new(pattern => qr/HASH/); +isa_ok($one, $CLASS, 'Test2::Compare::Base'); +is($one->name, "" . qr/HASH/, "got name"); +is($one->operator, '=~', "got operator"); +ok(!$one->verify(got => {}, exists => 1), "A hashref does not validate against the pattern 'HASH'"); +ok(!$one->verify(exists => 0), "DNE does not validate"); +ok(!$one->verify(exists => 1, got => undef), "undef does not validate"); +ok(!$one->verify(exists => 1, got => 'foo'), "Not a match"); +ok($one->verify(exists => 1, got => 'A HASH B'), "Matches"); + +$one = $CLASS->new(pattern => qr/HASH/, negate => 1); +isa_ok($one, $CLASS, 'Test2::Compare::Base'); +is($one->name, "" . qr/HASH/, "got name"); +is($one->operator, '!~', "got operator"); +ok(!$one->verify(exists => 1, got => {}), "A hashref does not validate against the pattern 'HASH' even when negated"); +ok(!$one->verify(exists => 0), "DNE does not validate"); +ok(!$one->verify(exists => 1, got => undef), "undef does not validate"); +ok($one->verify(exists => 1, got => 'foo'), "Not a match, but negated"); +ok(!$one->verify(exists => 1, got => 'A HASH B'), "Matches, but negated"); + + +like( + dies { $CLASS->new }, + qr/'pattern' is a required attribute/, + "Need to specify a pattern" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Ref.t b/cpan/Test2-Suite/t/modules/Compare/Ref.t new file mode 100644 index 000000000000..3aec08246abf --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Ref.t @@ -0,0 +1,37 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Ref'; + +my $ref = sub { 1 }; +my $one = $CLASS->new(input => $ref); +isa_ok($one, $CLASS, 'Test2::Compare::Base'); + +like($one->name, qr/CODE\(.*\)/, "Got Name"); +is($one->operator, '==', "got operator"); + +ok($one->verify(exists => 1, got => $ref), "verified ref"); +ok(!$one->verify(exists => 1, got => sub { 1 }), "different ref"); +ok(!$one->verify(exists => 0, got => $ref), "value must exist"); + +is( + [ 'a', $ref ], + [ 'a', $one ], + "Did a ref check" +); + +ok(!$one->verify(exists => 1, got => 'a'), "not a ref"); + +$one->set_input('a'); +ok(!$one->verify(exists => 1, got => $ref), "input not a ref"); + +like( + dies { $CLASS->new() }, + qr/'input' is a required attribute/, + "Need input" +); + +like( + dies { $CLASS->new(input => 'a') }, + qr/'input' must be a reference, got 'a'/, + "Input must be a ref" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Regex.t b/cpan/Test2-Suite/t/modules/Compare/Regex.t new file mode 100644 index 000000000000..694b48010afa --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Regex.t @@ -0,0 +1,33 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Regex'; + +my $one = $CLASS->new(input => qr/abc/i); + +is(qr/abc/i, $one, "same regex"); + +ok(!$one->verify(got => qr/xyz/i, exists => 1), "Different regex"); +ok(!$one->verify(got => qr/abc/, exists => 1), "Different flags"); +ok(!$one->verify(exists => 0), "Must exist"); + +ok(!$one->verify(exists => 1, got => {}), "Must be regex"); +ok(!$one->verify(exists => 1, got => undef), "Must be defined"); +ok(!$one->verify(exists => 1, got => 'aaa'), "String is not valid"); + +is($one->name, "" . qr/abc/i, "name is regex pattern"); + +is($one->operator, 'eq', "got operator"); + +ok($one->verify(got => qr/abc/i, exists => 1), "Same regex"); + +like( + dies { $CLASS->new() }, + qr/'input' is a required attribute/, + "require a pattern" +); + +like( + dies { $CLASS->new(input => 'foo') }, + qr/'input' must be a regex , got 'foo'/, + "must be a regex" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Scalar.t b/cpan/Test2-Suite/t/modules/Compare/Scalar.t new file mode 100644 index 000000000000..5cdceb48f933 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Scalar.t @@ -0,0 +1,40 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Scalar'; + +my $one = $CLASS->new(item => 'foo'); +is($one->name, '', "got name"); +is($one->operator, '${...}', "Got operator"); + +ok(!$one->verify(exists => 0), "nothing to verify"); +ok(!$one->verify(exists => 1, got => undef), "undef"); +ok(!$one->verify(exists => 1, got => 'a'), "not a ref"); +ok(!$one->verify(exists => 1, got => {}), "not a scalar ref"); + +ok($one->verify(exists => 1, got => \'anything'), "Scalar ref"); + +my $convert = Test2::Compare->can('strict_convert'); + +is( + [$one->deltas(got => \'foo', convert => $convert, seen => {})], + [], + "Exact match, no delta" +); + +like( + [$one->deltas(got => \'bar', convert => $convert, seen => {})], + [ + { + got => 'bar', + id => [SCALAR => '$*'], + chk => {'input' => 'foo'}, + } + ], + "Value pointed to is different" +); + +like( + dies { $CLASS->new() }, + qr/'item' is a required attribute/, + "item is required" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Set.t b/cpan/Test2-Suite/t/modules/Compare/Set.t new file mode 100644 index 000000000000..658907b46020 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Set.t @@ -0,0 +1,144 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Set'; + +subtest construction => sub { + my $one = $CLASS->new(); + isa_ok($one, 'Test2::Compare::Base', $CLASS); + is($one->reduction, 'any', "default to 'any'"); + is($one->checks, [], "default to empty list of checks"); + is($one->name, '', "got name"); + is($one->operator, 'any', "got op"); + + $one = $CLASS->new(checks => [ 'a', 'b' ], reduction => 'all'); + isa_ok($one, 'Test2::Compare::Base', $CLASS); + is($one->reduction, 'all', "specified reduction"); + is($one->checks, ['a', 'b'], "specified checks"); + is($one->name, '', "got name"); + is($one->operator, 'all', "got op"); + + like( + dies { $CLASS->new(reduction => 'fake') }, + qr/'fake' is not a valid set reduction/, + "Need a valid reduction", + ); +}; + +subtest set_reduction => sub { + my $one = $CLASS->new(); + is($one->reduction, 'any', "default"); + $one->set_reduction('all'); + is($one->reduction, 'all', "changed"); + + like( + dies { $one->set_reduction('fake') }, + qr/'fake' is not a valid set reduction/, + "Need a valid reduction", + ); +}; + +subtest verify => sub { + my $one = $CLASS->new(); + + is($one->verify(exists => 1), 1, "valid"); + + # in_set(DNE) is a valid construct, so we cannot reject non-existing values. + is($one->verify(exists => 0), 1, "valid"); +}; + +subtest add_check => sub { + my $one = $CLASS->new(checks => ['a']); + $one->add_check('b'); + $one->add_check(match qr/xxx/); + + is( + $one->checks, + [ 'a', 'b', meta { prop blessed => 'Test2::Compare::Pattern' } ], + "Added the checks" + ); +}; + +subtest deltas => sub { + my $one; + + my $after_each = sub { + $one->set_checks(undef); + is( + dies { $one->deltas() }, + "No checks defined for set\n", + "Need checks list" + ); + + $one->set_checks([]); + $one->set_file(__FILE__); my $file = __FILE__; + is( + dies { $one->deltas() }, + "No checks defined for set\n", + "Need checks in list" + ); + + $one->set_checks(undef); + $one->set_lines([__LINE__]); my $line1 = __LINE__; + is( + dies { $one->deltas() }, + "No checks defined for set (Set defined in $file line $line1)\n", + "Need checks list, have file+line" + ); + + $one->set_checks([]); + push @{$one->lines} => __LINE__; my $line2 = __LINE__; + is( + dies { $one->deltas() }, + "No checks defined for set (Set defined in $file lines $line1, $line2)\n", + "Need checks in list, have file + 2 lines" + ); + }; + + subtest any => sub { + $one = $CLASS->new(reduction => 'any'); + $one->add_check(match qr/a/); + $one->add_check(match qr/b/); + $one->add_check(match qr/c/); + + is('xax', $one, "matches 'a'"); + is('xbx', $one, "matches 'b'"); + is('xcx', $one, "matches 'c'"); + + is([$one->deltas(got => 'a', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'a'"); + is([$one->deltas(got => 'b', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'b'"); + is([$one->deltas(got => 'c', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'c'"); + + like( + [$one->deltas(got => 'x', exists => 1, seen => {}, convert => sub { $_[0] })], + [{ got => 'x' }, { got => 'x' }, { got => 'x' }, DNE], + "no matches, 3 deltas, one per check" + ); + + $after_each->(); + }; + + subtest all => sub { + $one = $CLASS->new(reduction => 'all'); + $one->add_check(mismatch qr/x/); + $one->add_check(match qr/fo/); + $one->add_check(match qr/oo/); + + is('foo', $one, "matches all 3"); + + is([$one->deltas(got => 'foo', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'foo'"); + + like( + [$one->deltas(got => 'oo', exists => 1, seen => {}, convert => sub { $_[0] })], + [{ got => 'oo' }, DNE], + "1 delta, one failed check" + ); + + like( + [$one->deltas(got => 'fox', exists => 1, seen => {}, convert => sub { $_[0] })], + [{ got => 'fox' }, { got => 'fox' }, DNE], + "2 deltas, one per failed check" + ); + + $after_each->(); + }; +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/String.t b/cpan/Test2-Suite/t/modules/Compare/String.t new file mode 100644 index 000000000000..8a09628c8977 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/String.t @@ -0,0 +1,78 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::String'; + +my $number = $CLASS->new(input => '22.0'); +my $string = $CLASS->new(input => 'hello'); +my $untru1 = $CLASS->new(input => ''); +my $untru2 = $CLASS->new(input => 0); + +isa_ok($_, $CLASS, 'Test2::Compare::Base') for $number, $string, $untru1, $untru2; + +subtest name => sub { + is($number->name, '22.0', "got expected name"); + is($string->name, 'hello', "got expected name"); + is($untru1->name, '', "got expected name"); + is($untru2->name, '0', "got expected name"); +}; + +subtest operator => sub { + is($number->operator(), '', "no operator for number + nothing"); + is($number->operator(undef), '', "no operator for number + undef"); + is($number->operator('x'), 'eq', "eq operator for number + string"); + is($number->operator(1), 'eq', "eq operator for number + number"); + + is($string->operator(), '', "no operator for string + nothing"); + is($string->operator(undef), '', "no operator for string + undef"); + is($string->operator('x'), 'eq', "eq operator for string + string"); + is($string->operator(1), 'eq', "eq operator for string + number"); + + is($untru1->operator(), '', "no operator for empty string + nothing"); + is($untru1->operator(undef), '', "no operator for empty string + undef"); + is($untru1->operator('x'), 'eq', "eq operator for empty string + string"); + is($untru1->operator(1), 'eq', "eq operator for empty string + number"); + + is($untru2->operator(), '', "no operator for 0 + nothing"); + is($untru2->operator(undef), '', "no operator for 0 + undef"); + is($untru2->operator('x'), 'eq', "eq operator for 0 + string"); + is($untru2->operator(1), 'eq', "eq operator for 0 + number"); +}; + +subtest verify => sub { + ok(!$number->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$number->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$number->verify(exists => 1, got => undef), 'looking for a number, not undef'); + ok(!$number->verify(exists => 1, got => 'x'), 'not looking for a string'); + ok(!$number->verify(exists => 1, got => 1), 'wrong number'); + ok(!$number->verify(exists => 1, got => 22), '22.0 ne 22'); + ok($number->verify(exists => 1, got => '22.0'), 'exact match with decimal'); + + ok(!$string->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$string->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$string->verify(exists => 1, got => undef), 'looking for a string, not undef'); + ok(!$string->verify(exists => 1, got => 'x'), 'looking for a different string'); + ok(!$string->verify(exists => 1, got => 1), 'looking for a string, not a number'); + ok($string->verify(exists => 1, got => 'hello'), 'exact match'); + + ok(!$untru1->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$untru1->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$untru1->verify(exists => 1, got => undef), 'looking for a string, not undef'); + ok(!$untru1->verify(exists => 1, got => 'x'), 'wrong string'); + ok(!$untru1->verify(exists => 1, got => 1), 'not a number'); + ok($untru1->verify(exists => 1, got => ''), 'exact match, empty string'); + + ok(!$untru2->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$untru2->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$untru2->verify(exists => 1, got => undef), 'undef is not 0 for this test'); + ok(!$untru2->verify(exists => 1, got => 'x'), 'x is not 0'); + ok(!$untru2->verify(exists => 1, got => 1), '1 is not 0'); + ok(!$untru2->verify(exists => 1, got => '0.0'), '0.0 ne 0'); + ok(!$untru2->verify(exists => 1, got => '-0.0'), '-0.0 ne 0'); + ok($untru2->verify(exists => 1, got => 0), 'got 0'); +}; + +like( + dies { $CLASS->new() }, + qr/input must be defined for 'String' check/, + "Cannot use undef as a string" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Undef.t b/cpan/Test2-Suite/t/modules/Compare/Undef.t new file mode 100644 index 000000000000..2c6ccfdcd421 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Undef.t @@ -0,0 +1,38 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Undef'; + +my $undef = $CLASS->new(); +my $isdef = $CLASS->new(negate => 1); + +isa_ok($undef, $CLASS, 'Test2::Compare::Base'); +isa_ok($isdef, $CLASS, 'Test2::Compare::Base'); + +subtest name => sub { + is($undef->name, '', "got expected name for undef"); + is($isdef->name, '', "got expected name for negated undef"); +}; + +subtest operator => sub { + is($undef->operator(), 'IS', "Operator is 'IS'"); + is($undef->operator('a'), 'IS', "Operator is 'IS'"); + + is($isdef->operator(), 'IS NOT', "Operator is 'IS NOT'"); + is($isdef->operator('a'), 'IS NOT', "Operator is 'IS NOT'"); +}; + +subtest verify => sub { + ok(!$undef->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$undef->verify(exists => 1, got => {}), 'ref will not verify'); + ok(!$undef->verify(exists => 1, got => 'x'), 'not looking for a string'); + ok(!$undef->verify(exists => 1, got => 1), 'not looking for a number'); + ok(!$undef->verify(exists => 1, got => 0), 'not looking for a 0'); + ok($undef->verify(exists => 1, got => undef), 'got undef'); + + ok(!$isdef->verify(exists => 0, got => undef), 'does not verify against DNE'); + ok(!$isdef->verify(exists => 1, got => undef), 'got undef'); + ok($isdef->verify(exists => 1, got => {}), 'ref is defined'); + ok($isdef->verify(exists => 1, got => 'x'), 'string is defined'); + ok($isdef->verify(exists => 1, got => 1), 'number is defined'); + ok($isdef->verify(exists => 1, got => 0), '0 is defined'); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Compare/Wildcard.t b/cpan/Test2-Suite/t/modules/Compare/Wildcard.t new file mode 100644 index 000000000000..964861bed5a9 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Compare/Wildcard.t @@ -0,0 +1,16 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Wildcard'; + +my $one = $CLASS->new(expect => 'foo'); +isa_ok($one, $CLASS, 'Test2::Compare::Base'); + +ok(defined $CLASS->new(expect => 0), "0 is a valid expect value"); +ok(defined $CLASS->new(expect => undef), "undef is a valid expect value"); +ok(defined $CLASS->new(expect => ''), "'' is a valid expect value"); + +like( + dies { $CLASS->new() }, + qr/'expect' is a require attribute/, + "Need to specify 'expect'" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Mock.t b/cpan/Test2-Suite/t/modules/Mock.t new file mode 100644 index 000000000000..1eeeba6dff8e --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Mock.t @@ -0,0 +1,935 @@ +use Test2::Bundle::Extended -target => 'Test2::Mock'; +use Test2::API qw/context/; + +use Scalar::Util qw/blessed/; + +# If we reuse the same package name (Fake) over and over we can end up +# triggering some weird Perl core issues. With Perl 5.14 and 5.16 we were +# seeing "panic: gp_free failed to free glob pointer - something is repeatedly +# re-creating entries at ..." +# +# So instead we use Fake, Fake2, Fake3, etc. It's not very elegant, but it +# gets the job done. + +subtest construction => sub { + my %calls; + my $c = Test2::Mock->new( + class => 'Test2::Mock', + before => [ class => sub { $calls{class}++ } ], + override => [ + parent => sub { $calls{parent}++ }, + child => sub { $calls{child}++ }, + ], + add => [ + foo => sub { $calls{foo}++ }, + ], + ); + + my $one = Test2::Mock->new( + class => 'Fake', + parent => 'Fake', + child => 'Fake', + foo => 'Fake', + ); + isa_ok($one, 'Test2::Mock'); + + is( + \%calls, + { foo => 1 }, + "Only called foo, did not call class, parent or child" + ); + + $c->reset_all; + + my @args; + $c->add(foo => sub { push @args => \@_ }); + + $one = Test2::Mock->new( + class => 'Fake', + foo => 'string', + foo => [qw/a list/], + foo => {a => 'hash'}, + ); + isa_ok($one, 'Test2::Mock'); + + is( + \@args, + [ + [$one, 'string'], + [$one, qw/a list/], + [$one, qw/a hash/], + ], + "Called foo with proper args, called it multiple times" + ); + + like( + dies { Test2::Mock->new }, + qr/The 'class' field is required/, + "Must specify a class" + ); + + like( + dies { Test2::Mock->new(class => 'Fake', foo => sub { 1 }) }, + qr/'CODE\(.*\)' is not a valid argument for 'foo'/, + "Val must be sane" + ); +}; + +subtest check => sub { + my $one = Test2::Mock->new(class => 'Fake1'); + + ok(lives { $one->_check }, "did not die"); + + $one->set_child(1); + + like( + dies {$one->_check}, + qr/There is an active child controller, cannot proceed/, + "Cannot use a controller when it has a child" + ); +}; + +subtest purge_on_destroy => sub { + my $one = Test2::Mock->new(class => 'Fake2'); + + ok(!$one->purge_on_destroy, "Not set by default"); + $one->purge_on_destroy(1); + ok($one->purge_on_destroy, "Can set"); + $one->purge_on_destroy(0); + ok(!$one->purge_on_destroy, "Can Unset"); + + { + # need to hide the glob assignment from the parser. + no strict 'refs'; + *{"Fake2::foo"} = sub { 'foo' }; + } + + can_ok('Fake2', 'foo'); + $one = undef; + can_ok('Fake2', 'foo'); # Not purged + + $one = Test2::Mock->new(class => 'Fake2'); + $one->purge_on_destroy(1); + $one = undef; + my $stash = do { no strict 'refs'; \%{"Fake2::"}; }; + ok(!keys %$stash, "no keys left in stash"); + ok(!Fake2->can('foo'), 'purged sub'); +}; + +subtest stash => sub { + my $one = Test2::Mock->new(class => 'Fake3'); + my $stash = $one->stash; + + ok($stash, "got a stash"); + is($stash, {}, "stash is empty right now"); + + { + # need to hide the glob assignment from the parser. + no strict 'refs'; + *{"Fake3::foo"} = sub { 'foo' }; + } + + ok($stash->{foo}, "See the new sub in the stash"); + ok(*{$stash->{foo}}{CODE}, "Code slot is populated"); +}; + +subtest file => sub { + my $fake = Test2::Mock->new(class => 'Fake4'); + my $complex = Test2::Mock->new(class => "A::Fake'Module::With'Separators"); + + is($fake->file, "Fake4.pm", "Got simple filename"); + + is($complex->file, "A/Fake/Module/With/Separators.pm", "got complex filename"); +}; + +subtest block_load => sub { + my $one; + + my $construction = sub { + $one = Test2::Mock->new(class => 'Fake5', block_load => 1); + }; + + my $post_construction = sub { + $one = Test2::Mock->new(class => 'Fake5'); + $one->block_load; + }; + + for my $case ($construction, $post_construction) { + $one = undef; + ok(!$INC{'Fake5.pm'}, "Does not appear to be loaded yet"); + + $case->(); + + ok($INC{'Fake5.pm'}, '%INC is populated'); + + $one = undef; + ok(!$INC{'Fake5.pm'}, "Does not appear to be loaded anymore"); + } +}; + +subtest block_load_fail => sub { + $INC{'Fake6.pm'} = 'path/to/Fake6.pm'; + + my $one = Test2::Mock->new(class => 'Fake6'); + + like( + dies { $one->block_load }, + qr/Cannot block the loading of module 'Fake6', already loaded in file/, + "Fails if file is already loaded" + ); +}; + +subtest constructors => sub { + my $one = Test2::Mock->new( + class => 'Fake7', + add_constructor => [new => 'hash'], + ); + + can_ok('Fake7', 'new'); + + my $i = Fake7->new(foo => 'bar'); + isa_ok($i, 'Fake7'); + is($i, { foo => 'bar' }, "Has params"); + + $one->override_constructor(new => 'ref'); + + my $ref = { 'foo' => 'baz' }; + $i = Fake7->new($ref); + isa_ok($i, 'Fake7'); + is($i, { foo => 'baz' }, "Has params"); + is($i, $ref, "same reference"); + ok(blessed($ref), "blessed original ref"); + + $one->override_constructor(new => 'ref_copy'); + $ref = { 'foo' => 'bat' }; + $i = Fake7->new($ref); + isa_ok($i, 'Fake7'); + is($i, { foo => 'bat' }, "Has params"); + ok($i != $ref, "different reference"); + ok(!blessed($ref), "original ref is not blessed"); + + $ref = [ 'foo', 'bar' ]; + $i = Fake7->new($ref); + isa_ok($i, 'Fake7'); + is($i, [ 'foo', 'bar' ], "has the items"); + ok($i != $ref, "different reference"); + ok(!blessed($ref), "original ref is not blessed"); + + like( + dies { $one->override_constructor(new => 'bad') }, + qr/'bad' is not a known constructor type/, + "Bad constructor type (override)" + ); + + like( + dies { $one->add_constructor(uhg => 'bad') }, + qr/'bad' is not a known constructor type/, + "Bad constructor type (add)" + ); + + $one->override_constructor(new => 'array'); + $one = Fake7->new('a', 'b'); + is($one, ['a', 'b'], "is an array"); + isa_ok($one, 'Fake7'); +}; + +subtest autoload => sub { + my $one = Test2::Mock->new( + class => 'Fake8', + add_constructor => [new => 'hash'], + ); + + my $i = Fake8->new; + isa_ok($i, 'Fake8'); + + ok(!$i->can('foo'), "Cannot do 'foo'"); + like(dies {$i->foo}, qr/Can't locate object method "foo" via package "Fake8"/, "Did not autload"); + + $one->autoload; + + ok(lives { $i->foo }, "Created foo") || return; + can_ok($i, 'foo'); # Added the sub to the package + + is($i->foo, undef, "no value"); + $i->foo('bar'); + is($i->foo, 'bar', "set value"); + $i->foo(undef); + is($i->foo, undef, "unset value"); + + ok( + dies { $one->autoload }, + qr/Class 'Fake8' already has an AUTOLOAD/, + "Cannot add additional autoloads" + ); + + $one->reset_all; + + ok(!$i->can('AUTOLOAD'), "AUTOLOAD removed"); + ok(!$i->can('foo'), "AUTOLOADed sub removed"); + + $one->autoload; + $i->foo; + + ok($i->can('AUTOLOAD'), "AUTOLOAD re-added"); + ok($i->can('foo'), "AUTOLOADed sub re-added"); + + $one = undef; + + ok(!$i->can('AUTOLOAD'), "AUTOLOAD removed (destroy)"); + ok(!$i->can('foo'), "AUTOLOADed sub removed (destroy)"); + + my $two = Test2::Mock->new( + class => 'Fake88', + add_constructor => [new => 'hash'], + track => 1, + autoload => 1, + ); + + my $j = Fake88->new; + ok(lives { $j->foo }, "Created foo") || return; + can_ok($j, 'foo'); # Added the sub to the package + + is( + $two->sub_tracking, + {foo => [{sub_name => 'foo', sub_ref => T, args => [exact_ref($j)]}]}, + "Tracked autoloaded sub (sub tracking)" + ); + + is( + $two->call_tracking, + [{sub_name => 'foo', sub_ref => T, args => [exact_ref($j)]}], + "Tracked autoloaded sub (call tracking)" + ); + +}; + +subtest autoload_failures => sub { + my $one = Test2::Mock->new(class => 'fake'); + + $one->add('AUTOLOAD' => sub { 1 }); + + like( + dies { $one->autoload }, + qr/Class 'fake' already has an AUTOLOAD/, + "Cannot add autoload when there is already an autoload" + ); + + $one = undef; + + $one = Test2::Mock->new(class => 'bad package'); + like( + dies { $one->autoload }, + qr/syntax error/, + "Error inside the autoload eval" + ); +}; + +subtest ISA => sub { + # This is to satisfy perl that My::Parent is loaded + no warnings 'once'; + local *My::Parent::foo = sub { 'foo' }; + + my $one = Test2::Mock->new( + class => 'Fake9', + add_constructor => [new => 'hash'], + add => [ + -ISA => ['My::Parent'], + ], + ); + + isa_ok('Fake9', 'My::Parent'); + is(Fake9->foo, 'foo', "Inherited sub from parent"); +}; + +subtest before => sub { + { + # need to hide the glob assignment from the parser. + no strict 'refs'; + *{"Fake10::foo"} = sub { 'foo' }; + } + + my $thing; + + my $one = Test2::Mock->new(class => 'Fake10'); + $one->before('foo' => sub { $thing = 'ran before foo' }); + + ok(!$thing, "nothing ran yet"); + is(Fake10->foo, 'foo', "got expected return"); + is($thing, 'ran before foo', "ran the before"); +}; + +subtest before => sub { + my $want; + { + # need to hide the glob assignment from the parser. + no strict 'refs'; + *{"Fake11::foo"} = sub { + $want = wantarray; + return qw/f o o/ if $want; + return 'foo' if defined $want; + return; + }; + } + + my $ran = 0; + + my $one = Test2::Mock->new(class => 'Fake11'); + $one->after('foo' => sub { $ran++ }); + + is($ran, 0, "nothing ran yet"); + + is(Fake11->foo, 'foo', "got expected return (scalar)"); + is($ran, 1, "ran the before"); + ok(defined($want) && !$want, "scalar context"); + + is([Fake11->foo], [qw/f o o/], "got expected return (list)"); + is($ran, 2, "ran the before"); + is($want, 1, "list context"); + + Fake11->foo; # Void return + is($ran, 3, "ran the before"); + is($want, undef, "void context"); +}; + +subtest around => sub { + my @things; + { + # need to hide the glob assignment from the parser. + no strict 'refs'; + *{"Fake12::foo"} = sub { + push @things => ['foo', \@_]; + }; + } + + my $one = Test2::Mock->new(class => 'Fake12'); + $one->around(foo => sub { + my ($orig, @args) = @_; + push @things => ['pre', \@args]; + $orig->('injected', @args); + push @things => ['post', \@args]; + }); + + Fake12->foo(qw/a b c/); + + is( + \@things, + [ + ['pre' => [qw/Fake12 a b c/]], + ['foo' => [qw/injected Fake12 a b c/]], + ['post' => [qw/Fake12 a b c/]], + ], + "Got all the things!" + ); +}; + +subtest 'add and current' => sub { + my $one = Test2::Mock->new( + class => 'Fake13', + add_constructor => [new => 'hash'], + add => [ + foo => { val => 'foo' }, + bar => 'rw', + baz => { is => 'rw', field => '_baz' }, + -DATA => { my => 'data' }, + -DATA => [ qw/my data/ ], + -DATA => sub { 'my data' }, + -DATA => \"data", + ], + ); + + # Do some outside constructor to test both paths + $one->add( + reader => 'ro', + writer => 'wo', + -UHG => \"UHG", + rsub => { val => sub { 'rsub' } }, + + # Without $x the compiler gets smart and makes it always return the + # same reference. + nsub => sub { my $x = ''; sub { $x . 'nsub' } }, + ); + + can_ok('Fake13', qw/new foo bar baz DATA reader writer rsub nsub/); + + like( + dies { $one->add(foo => sub { 'nope' }) }, + qr/Cannot add '&Fake13::foo', symbol is already defined/, + "Cannot add a CODE symbol that is already defined" + ); + + like( + dies { $one->add(-UHG => \'nope') }, + qr/Cannot add '\$Fake13::UHG', symbol is already defined/, + "Cannot add a SCALAR symbol that is already defined" + ); + + my $i = Fake13->new(); + is($i->foo, 'foo', "by value"); + + is($i->bar, undef, "Accessor not set"); + is($i->bar('bar'), 'bar', "Accessor setting"); + is($i->bar, 'bar', "Accessor was set"); + + is($i->baz, undef, "no value yet"); + ok(!$i->{_bar}, "hash element is empty"); + is($i->baz('baz'), 'baz', "setting"); + is($i->{_baz}, 'baz', "set field"); + is($i->baz, 'baz', "got value"); + + is($i->reader, undef, "No value for reader"); + is($i->reader('oops'), undef, "No value set"); + is($i->reader, undef, "Still No value for reader"); + is($i->{reader}, undef, 'element is empty'); + $i->{reader} = 'yay'; + is($i->{reader}, 'yay', 'element is set'); + + is($i->{writer}, undef, "no value yet"); + $i->writer; + is($i->{writer}, undef, "Set to undef"); + is($i->writer('xxx'), 'xxx', "Adding value"); + is($i->{writer}, 'xxx', "was set"); + is($i->writer, undef, "writer always writes"); + is($i->{writer}, undef, "Set to undef"); + + is($i->rsub, $i->rsub, "rsub always returns the same ref"); + is($i->rsub->(), 'rsub', "ran rsub"); + + ok($i->nsub != $i->nsub, "nsub returns a new ref each time"); + is($i->nsub->(), 'nsub', "ran nsub"); + + is($i->DATA, 'my data', "direct sub assignment"); + # These need to be eval'd so the parser does not shortcut the glob references + ok(eval <<' EOT', "Ran glob checks") || diag "Error: $@"; + is($Fake13::UHG, 'UHG', "Set package scalar (UHG)"); + is($Fake13::DATA, 'data', "Set package scalar (DATA)"); + is(\%Fake13::DATA, { my => 'data' }, "Set package hash"); + is(\@Fake13::DATA, [ my => 'data' ], "Set package array"); + 1; + EOT + + is($one->current($_), $i->can($_), "current works for sub $_") + for qw/new foo bar baz DATA reader writer rsub nsub/; + + is(${$one->current('$UHG')}, 'UHG', 'got current $UHG'); + is(${$one->current('$DATA')}, 'data', 'got current $DATA'); + is($one->current('&DATA'), $i->can('DATA'), 'got current &DATA'); + is($one->current('@DATA'), [qw/my data/], 'got current @DATA'); + is($one->current('%DATA'), {my => 'data'}, 'got current %DATA'); + + $one = undef; + + ok(!Fake13->can($_), "Removed sub $_") for qw/new foo bar baz DATA reader writer rsub nsub/; + + $one = Test2::Mock->new(class => 'Fake13'); + + # Scalars are tricky, skip em for now. + is($one->current('&DATA'), undef, 'no current &DATA'); + is($one->current('@DATA'), undef, 'no current @DATA'); + is($one->current('%DATA'), undef, 'no current %DATA'); +}; + +subtest 'override and orig' => sub { + # Define things so we can override them + eval <<' EOT' || die $@; + package Fake14; + + sub new { 'old' } + + sub foo { 'old' } + sub bar { 'old' } + sub baz { 'old' } + + sub DATA { 'old' } + our $DATA = 'old'; + our %DATA = (old => 'old'); + our @DATA = ('old'); + + our $UHG = 'old'; + + sub reader { 'old' } + sub writer { 'old' } + sub rsub { 'old' } + sub nsub { 'old' } + EOT + + my $check_initial = sub { + is(Fake14->$_, 'old', "$_ is not overriden") for qw/new foo bar baz DATA reader writer rsub nsub/; + ok(eval <<' EOT', "Ran glob checks") || diag "Error: $@"; + is($Fake14::UHG, 'old', 'old package scalar (UHG)'); + is($Fake14::DATA, 'old', "Old package scalar (DATA)"); + is(\%Fake14::DATA, {old => 'old'}, "Old package hash"); + is(\@Fake14::DATA, ['old'], "Old package array"); + 1; + EOT + }; + + $check_initial->(); + + my $one = Test2::Mock->new( + class => 'Fake14', + override_constructor => [new => 'hash'], + override => [ + foo => { val => 'foo' }, + bar => 'rw', + baz => { is => 'rw', field => '_baz' }, + -DATA => { my => 'data' }, + -DATA => [ qw/my data/ ], + -DATA => sub { 'my data' }, + -DATA => \"data", + ], + ); + + # Do some outside constructor to test both paths + $one->override( + reader => 'ro', + writer => 'wo', + -UHG => \"UHG", + rsub => { val => sub { 'rsub' } }, + + # Without $x the compiler gets smart and makes it always return the + # same reference. + nsub => sub { my $x = ''; sub { $x . 'nsub' } }, + ); + + like( + dies { $one->override(nuthin => sub { 'nope' }) }, + qr/Cannot override '&Fake14::nuthin', symbol is not already defined/, + "Cannot override a CODE symbol that is not defined" + ); + + like( + dies { $one->override(-nuthin2 => \'nope') }, + qr/Cannot override '\$Fake14::nuthin2', symbol is not already defined/, + "Cannot override a SCALAR symbol that is not defined" + ); + + my $i = Fake14->new(); + is($i->foo, 'foo', "by value"); + + is($i->bar, undef, "Accessor not set"); + is($i->bar('bar'), 'bar', "Accessor setting"); + is($i->bar, 'bar', "Accessor was set"); + + is($i->baz, undef, "no value yet"); + ok(!$i->{_bar}, "hash element is empty"); + is($i->baz('baz'), 'baz', "setting"); + is($i->{_baz}, 'baz', "set field"); + is($i->baz, 'baz', "got value"); + + is($i->reader, undef, "No value for reader"); + is($i->reader('oops'), undef, "No value set"); + is($i->reader, undef, "Still No value for reader"); + is($i->{reader}, undef, 'element is empty'); + $i->{reader} = 'yay'; + is($i->{reader}, 'yay', 'element is set'); + + is($i->{writer}, undef, "no value yet"); + $i->writer; + is($i->{writer}, undef, "Set to undef"); + is($i->writer('xxx'), 'xxx', "Adding value"); + is($i->{writer}, 'xxx', "was set"); + is($i->writer, undef, "writer always writes"); + is($i->{writer}, undef, "Set to undef"); + + is($i->rsub, $i->rsub, "rsub always returns the same ref"); + is($i->rsub->(), 'rsub', "ran rsub"); + + ok($i->nsub != $i->nsub, "nsub returns a new ref each time"); + is($i->nsub->(), 'nsub', "ran nsub"); + + is($i->DATA, 'my data', "direct sub assignment"); + # These need to be eval'd so the parser does not shortcut the glob references + ok(eval <<' EOT', "Ran glob checks") || diag "Error: $@"; + is($Fake14::UHG, 'UHG', "Set package scalar (UHG)"); + is($Fake14::DATA, 'data', "Set package scalar (DATA)"); + is(\%Fake14::DATA, { my => 'data' }, "Set package hash"); + is(\@Fake14::DATA, [ my => 'data' ], "Set package array"); + 1; + EOT + + is($one->current($_), $i->can($_), "current works for sub $_") + for qw/new foo bar baz DATA reader writer rsub nsub/; + + is(${$one->current('$UHG')}, 'UHG', 'got current $UHG'); + is(${$one->current('$DATA')}, 'data', 'got current $DATA'); + is($one->current('&DATA'), $i->can('DATA'), 'got current &DATA'); + is($one->current('@DATA'), [qw/my data/], 'got current @DATA'); + is($one->current('%DATA'), {my => 'data'}, 'got current %DATA'); + + is($one->orig($_)->(), 'old', "got original $_") for qw/new foo bar baz DATA reader writer rsub nsub/; + + is(${$one->orig('$UHG')}, 'old', 'old package scalar (UHG)'); + is(${$one->orig('$DATA')}, 'old', "Old package scalar (DATA)"); + is($one->orig('%DATA'), {old => 'old'}, "Old package hash"); + is($one->orig('@DATA'), ['old'], "Old package array"); + + like( + dies { $one->orig('not_mocked') }, + qr/Symbol '¬_mocked' is not mocked/, + "Cannot get original for something not mocked" + ); + + like( + dies { Test2::Mock->new(class => 'AnotherFake14')->orig('no_mocks') }, + qr/No symbols have been mocked yet/, + "Cannot get original when nothing is mocked" + ); + + $one = undef; + + $check_initial->(); +}; + +subtest restore_reset => sub { + my $one = Test2::Mock->new( class => 'Fake15' ); + + $one->add(foo => sub { 'a' }); + $one->add(-foo => \'a'); + $one->add(-foo => ['a']); + + $one->override(foo => sub { 'b' }); + $one->override(foo => sub { 'c' }); + $one->override(foo => sub { 'd' }); + $one->override(foo => sub { 'e' }); + + is(Fake15->foo, 'e', "latest override"); + is(eval '$Fake15::foo', 'a', "scalar override remains"); + is(eval '\@Fake15::foo', ['a'], "array override remains"); + + $one->restore('foo'); + is(Fake15->foo, 'd', "second latest override"); + is(eval '$Fake15::foo', 'a', "scalar override remains"); + is(eval '\@Fake15::foo', ['a'], "array override remains"); + + $one->restore('foo'); + is(Fake15->foo, 'c', "second latest override"); + is(eval '$Fake15::foo', 'a', "scalar override remains"); + is(eval '\@Fake15::foo', ['a'], "array override remains"); + + $one->reset('foo'); + ok(!Fake15->can('foo'), "no more override"); + is(eval '$Fake15::foo', 'a', "scalar override remains"); + is(eval '\@Fake15::foo', ['a'], "array override remains"); + + $one->add(foo => sub { 'a' }); + is(Fake15->foo, 'a', "override"); + + $one->reset_all; + ok(!Fake15->can('foo'), "no more override"); + is(eval '$Fake15::foo', undef, "scalar override removed"); + + no strict 'refs'; + ok(!*{'Fake15::foo'}{ARRAY}, "array override removed"); +}; + +subtest exceptions => sub { + my $one = Test2::Mock->new( class => 'Fake16' ); + like( + dies { $one->new(class => 'AnotherFake16') }, + qr/Called new\(\) on a blessed instance, did you mean to call \$control->class->new\(\)\?/, + "Cannot call new on a blessed instance" + ); + + like( + dies { Test2::Mock->new(class => 'AnotherFake16', foo => 1) }, + qr/'foo' is not a valid constructor argument for Test2::Mock/, + "Validate constructor args" + ); + + like( + dies { Test2::Mock->new(class => 'AnotherFake16', override_constructor => ['xxx', 'xxx']) }, + qr/'xxx' is not a known constructor type/, + "Invalid constructor type" + ); + + like( + dies { Test2::Mock->new(class => 'AnotherFake16', add_constructor => ['xxx', 'xxx']) }, + qr/'xxx' is not a known constructor type/, + "Invalid constructor type" + ); + + like( + dies { $one->orig('foo') }, + qr/No symbols have been mocked yet/, + "No symbols are mocked yet" + ); + + like( + dies { $one->restore('foo') }, + qr/No symbols are mocked/, + "No symbols yet!" + ); + + like( + dies { $one->reset('foo') }, + qr/No symbols are mocked/, + "No symbols yet!" + ); + + $one->add(xxx => sub { 1 }); + like( + dies { $one->orig('foo') }, + qr/Symbol '&foo' is not mocked/, + "did not mock foo" + ); + like( + dies { $one->restore('foo') }, + qr/Symbol '&foo' is not mocked/, + "did not mock foo" + ); + like( + dies { $one->reset('foo') }, + qr/Symbol '&foo' is not mocked/, + "did not mock foo" + ); + + my $bare = Test2::Mock->new( + class => 'Fake17', + autoload => 1, + ); + + like( + dies { $bare->override( missing => 1 ) }, + qr/Cannot override '&Fake17::missing', symbol is not already defined/, + "Cannot override a method that is not defined in an AUTOLOAD mock" + ); +}; + +subtest override_inherited_method => sub { + package ABC; + our @ISA = 'DEF'; + + package DEF; + + sub foo { 'foo' }; + + package main; + is(ABC->foo, 'foo', "Original"); + + my $mock = Test2::Mock->new(class => 'ABC'); + $mock->override('foo' => sub { 'bar' }); + is(ABC->foo, 'bar', "Overrode method from base class"); + + $mock->reset('foo'); + $mock->add('foo' => sub { 'baz' }); + is(ABC->foo, 'baz', "Added method"); +}; + +subtest set => sub { + package My::Set; + sub foo { 'foo' } + + package main; + + my $mock = Test2::Mock->new(class => 'My::Set'); + $mock->set(foo => sub { 'FOO' }); + $mock->set(bar => sub { 'BAR' }); + + is(My::Set->foo, 'FOO', "overrode 'foo'"); + is(My::Set->bar, 'BAR', "injected 'bar'"); +}; + +subtest tracking => sub { + package My::Track; + sub foo { 'foo' } + + package main; + + my $mock = Test2::Mock->new(class => 'My::Track', track => 1); + my $FOO = sub { 'FOO' }; + my $BAR = sub { 'BAR' }; + $mock->set(foo => $FOO); + $mock->set(bar => $BAR); + + is(My::Track->foo(1,2), 'FOO', "overrode 'foo'"); + is(My::Track->bar(3,4), 'BAR', "injected 'bar'"); + + is( + $mock->sub_tracking, + { + foo => [{sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}], + bar => [{sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}], + }, + "Tracked both initial calls (sub)" + ); + is( + $mock->call_tracking, + [ + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, + {sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]} + ], + "Tracked both initial calls (call)" + ); + + My::Track->foo(5, 6); + is( + $mock->sub_tracking, + { + foo => [ + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 5, 6]}, + ], + bar => [{sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}], + }, + "Tracked new call (sub)" + ); + is( + $mock->call_tracking, + [ + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, + {sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}, + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 5, 6]}, + ], + "Tracked new call (call)" + ); + + + $mock->clear_sub_tracking('xxx', 'foo'); + My::Track->foo(7, 8); + is( + $mock->sub_tracking, + { + foo => [{sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 7, 8]}], + bar => [{sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}], + }, + "Cleared specific sub, Tracked new call (sub)" + ); + is( + $mock->call_tracking, + [ + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, + {sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}, + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 5, 6]}, + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 7, 8]}, + ], + "did not clear call tracking" + ); + + $mock->clear_sub_tracking(); + is($mock->sub_tracking, {}, "Cleared all sub tracking"); + + $mock->clear_call_tracking(); + is($mock->call_tracking, [], "Cleared call tracking"); + + My::Track->foo(9, 10); + is( + $mock->sub_tracking, + { + foo => [{sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 9, 10]}], + }, + "Tracked new call (sub)" + ); + is( + $mock->call_tracking, + [ + {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 9, 10]}, + ], + "Tracked new call (call)" + ); + + $mock = undef; + + is(My::Track->foo, 'foo', "Original restored"); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Plugin.t b/cpan/Test2-Suite/t/modules/Plugin.t new file mode 100644 index 000000000000..e552ea3c479b --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Plugin.t @@ -0,0 +1,7 @@ +use Test2::Bundle::Extended; + +use Test2::Plugin; + +pass("Loaded Test2::Plugin"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Plugin/BailOnFail.t b/cpan/Test2-Suite/t/modules/Plugin/BailOnFail.t new file mode 100644 index 000000000000..0fd7003086f5 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Plugin/BailOnFail.t @@ -0,0 +1,47 @@ +use Test2::Bundle::Extended; + +use Test2::Plugin::BailOnFail; + +like( + intercept { + ok(1, "pass"); + ok(0, "fail"); + ok(1, "Should not see"); + }, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Ok => { name => "pass", pass => 1 }; + event Ok => { name => "fail", pass => 0 }; + event Bail => { reason => "(Bail On Fail)" }; + end; + }, + "Bailed after the failure" +); + +sub mok { + my ($ok, $name) = @_; + my $ctx = context(); + ok($ok, $name); + diag "Should see this after failure"; + $ctx->release; + return $ok; +} + +like( + intercept { + ok(1, "pass"); + mok(0, "fail"); + ok(1, "Should not see"); + }, + array { + event Ok => { name => "pass", pass => 1 }; + event Ok => { name => "fail", pass => 0 }; + event Diag => {}; # Typical failure diag + event Diag => { message => "Should see this after failure" }; + event Bail => { reason => "(Bail On Fail)" }; + end; + }, + "Tool had time to output the diag" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Plugin/DieOnFail.t b/cpan/Test2-Suite/t/modules/Plugin/DieOnFail.t new file mode 100644 index 000000000000..25bc8ac30574 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Plugin/DieOnFail.t @@ -0,0 +1,63 @@ +use Test2::Bundle::Extended; + +use Test2::Plugin::DieOnFail; + +my $error; +like( + intercept { + ok(1, "pass"); + $error = dies { + ok(0, "fail"); + ok(1, "Should not see"); + }; + }, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Ok => { name => "pass", pass => 1 }; + event Ok => { name => "fail", pass => 0 }; + end; + }, + "Died after the failure" +); + +like( + $error, + qr/\(Die On Fail\)/, + "Got the error" +); + +sub mok { + my ($ok, $name) = @_; + my $ctx = context(); + ok($ok, $name); + diag "Should see this after failure"; + $ctx->release; + return $ok; +} + +$error = undef; +like( + intercept { + ok(1, "pass"); + $error = dies { + mok(0, "fail"); + ok(1, "Should not see"); + }; + }, + array { + event Ok => { name => "pass", pass => 1 }; + event Ok => { name => "fail", pass => 0 }; + event Diag => {}; # Typical failure diag + event Diag => { message => "Should see this after failure" }; + end; + }, + "Tool had time to output the diag" +); + +like( + $error, + qr/\(Die On Fail\)/, + "Got the error" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Plugin/ExitSummary.t b/cpan/Test2-Suite/t/modules/Plugin/ExitSummary.t new file mode 100644 index 000000000000..3f51420dffdb --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Plugin/ExitSummary.t @@ -0,0 +1,88 @@ +use strict; +use warnings; +# HARNESS-NO-PRELOAD + +use Test2::API; + +my $initial_count; +BEGIN { $initial_count = Test2::API::test2_list_exit_callbacks() } + +use Test2::Tools::Basic; +use Test2::API qw/intercept context/; +use Test2::Tools::Compare qw/array event end is like/; + +use Test2::Plugin::ExitSummary; +use Test2::Plugin::ExitSummary; +use Test2::Plugin::ExitSummary; + +my $post_count = Test2::API::test2_list_exit_callbacks(); + +is($initial_count, 0, "no hooks initially"); +is($post_count, 1, "Added the hook, but only once"); + +my $summary = Test2::Plugin::ExitSummary->can('summary'); + +my $exit = 0; +my $new = 0; + +like( + intercept { + my $ctx = context(level => -1); + $summary->($ctx, $exit, \$new); + $ctx->release; + }, + array { event Diag => {message => 'No tests run!'}; end }, + "No tests run" +); + +like( + intercept { + plan 1; + my $ctx = context(level => -1); + $summary->($ctx, $exit, \$new); + $ctx->release; + }, + array { + event Plan => { max => 1 }; + event Diag => {message => 'No tests run!'}; + event Diag => {message => 'Did not follow plan: expected 1, ran 0.'}; + end + }, + "No tests run, bad plan" +); + +like( + intercept { + ok(1); + my $ctx = context(level => -1); + $summary->($ctx, $exit, \$new); + $ctx->release; + }, + array { + event Ok => { pass => 1 }; + event Diag => {message => 'Tests were run but no plan was declared and done_testing() was not seen.'}; + end + }, + "Tests, but no plan" +); + +$exit = 123; +$new = 123; +like( + intercept { + plan 1; + ok(1); + my $ctx = context(level => -1); + $summary->($ctx, $exit, \$new); + $ctx->release; + }, + array { + event Plan => { max => 1 }; + event Ok => { pass => 1 }; + event Diag => {message => 'Looks like your test exited with 123 after test #1.'}; + end + }, + "Bad exit code" +); + +done_testing(); diff --git a/cpan/Test2-Suite/t/modules/Plugin/SRand.t b/cpan/Test2-Suite/t/modules/Plugin/SRand.t new file mode 100644 index 000000000000..47767308bee3 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Plugin/SRand.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +use Test2::Tools::Basic; +use Test2::API qw/intercept test2_stack context/; +use Test2::Tools::Compare qw/array event end is like/; +use Test2::Tools::Target 'Test2::Plugin::SRand'; +use Test2::Tools::Warnings qw/warning/; + +test2_stack->top; +my ($root) = test2_stack->all; + +sub intercept_2(&) { + my $code = shift; + + # This is to force loading to happen + my $ctx = context(); + + my @events; + + my $l = $root->listen(sub { + my ($h, $e) = @_; + push @events => $e; + }); + + $code->(); + + $root->unlisten($l); + + $ctx->release; + + return \@events; +} + +{ + local %ENV = %ENV; + $ENV{HARNESS_IS_VERBOSE} = 1; + $ENV{T2_RAND_SEED} = 1234; + + my ($events, $warning); + my $reseed_qr = qr/SRand loaded multiple times, re-seeding rand/; + my $reseed_name = "Warned about resetting srand"; + + like( + intercept_2 { $CLASS->import('5555') }, + array { + event Note => { message => "Seeded srand with seed '5555' from import arg." }; + }, + "got the event" + ); + is($CLASS->seed, 5555, "set seed"); + is($CLASS->from, 'import arg', "set from"); + + $warning = warning { $events = intercept_2 { $CLASS->import(seed => 56789) } }; + like( + $events, + array { + event Note => { message => "Seeded srand with seed '56789' from import arg." }; + }, + "got the event" + ); + is($CLASS->seed, 56789, "set seed"); + is($CLASS->from, 'import arg', "set from"); + like($warning, $reseed_qr, $reseed_name); + + $warning = warning { $events = intercept_2 { $CLASS->import() } }; + like( + $events, + array { + event Note => { message => "Seeded srand with seed '1234' from environment variable." }; + }, + "got the event" + ); + is($CLASS->seed, 1234, "set seed"); + is($CLASS->from, 'environment variable', "set from"); + like($warning, $reseed_qr, $reseed_name); + + delete $ENV{T2_RAND_SEED}; + $warning = warning { $events = intercept_2 { $CLASS->import() } }; + like( + $events, + array { + event Note => { message => qr/Seeded srand with seed '\d{8}' from local date\./ }; + }, + "got the event" + ); + ok($CLASS->seed && $CLASS->seed != 1234, "set seed"); + is($CLASS->from, 'local date', "set from"); + like($warning, $reseed_qr, $reseed_name); + + my $hooks = Test2::API::test2_list_exit_callbacks(); + delete $ENV{HARNESS_IS_VERBOSE}; + $ENV{HARNESS_ACTIVE} = 1; + warning { $events = intercept { $CLASS->import() } }; + warning { $events = intercept { $CLASS->import() } }; + is(Test2::API::test2_list_exit_callbacks, $hooks + 1, "added hook, but only once"); + + warning { $CLASS->import(undef) }; + is($CLASS->seed, 0 , "set seed"); + is($CLASS->from, 'import arg', "set from"); +} + +done_testing(); diff --git a/cpan/Test2-Suite/t/modules/Plugin/Times.t b/cpan/Test2-Suite/t/modules/Plugin/Times.t new file mode 100644 index 000000000000..a2208a1b0791 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Plugin/Times.t @@ -0,0 +1,43 @@ +use strict; +use warnings; +use Test2::API qw/intercept context/; + +use Test2::Tools::Defer qw/def do_def/; + +use vars qw/@CALLBACKS/; + +BEGIN { + no warnings 'redefine'; + local *Test2::API::test2_add_callback_exit = sub { push @CALLBACKS => @_ }; + + require Test2::Plugin::Times; + def ok => (!scalar(@CALLBACKS), "requiring the module does not add a callback"); + + Test2::Plugin::Times->import(); + + def ok => (scalar(@CALLBACKS), "importing the module does add a callback"); +} + +use Test2::Tools::Basic; +use Test2::Tools::Compare qw/like/; + +do_def; + +my $events = intercept { + sub { + my $ctx = context(); + $CALLBACKS[0]->($ctx); + $ctx->release; + }->(); +}; + +like( + $events->[0]->summary, + qr/^\S+ on wallclock \([\d\.]+ usr [\d\.]+ sys \+ [\d\.]+ cusr [\d\.]+ csys = [\d\.]+ CPU\)$/, + "Got the time info" +); + +ok($events->[0]->{times}, "Got times"); +ok($events->[0]->{harness_job_fields}, "Got harness job fields"); + +done_testing(); diff --git a/cpan/Test2-Suite/t/modules/Plugin/UTF8.t b/cpan/Test2-Suite/t/modules/Plugin/UTF8.t new file mode 100644 index 000000000000..51374d2f051e --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Plugin/UTF8.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +# HARNESS-NO-FORMATTER + +# Store the default STDOUT and STDERR IO layers for later testing. +# This must happen before we load anything else. +use PerlIO (); +my %Layers; + +sub get_layers { + my $fh = shift; + return { map {$_ => 1} PerlIO::get_layers($fh) }; +} + +BEGIN { + $Layers{STDERR} = get_layers(*STDERR); + $Layers{STDOUT} = get_layers(*STDOUT); +} + +use Test2::Plugin::UTF8; +use Test2::Tools::Basic; +use Test2::Tools::Compare; +use Test2::API qw(test2_stack); + +note "pragma"; { + ok(utf8::is_utf8("癸"), "utf8 pragma is on"); +} + +note "io_layers"; { + is get_layers(*STDOUT), $Layers{STDOUT}, "STDOUT encoding is untouched"; + is get_layers(*STDERR), $Layers{STDERR}, "STDERR encoding is untouched"; +} + +note "format_handles"; { + my $format = test2_stack()->top->format; + my $handles = $format->handles or last; + for my $hn (0 .. @$handles) { + my $h = $handles->[$hn] || next; + my $layers = get_layers($h); + ok($layers->{utf8}, "utf8 is on for formatter handle $hn"); + } +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require.t b/cpan/Test2-Suite/t/modules/Require.t new file mode 100644 index 000000000000..dc27b086275b --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require.t @@ -0,0 +1,52 @@ +use Test2::Bundle::Extended; + +use Test2::Require; +pass "Loaded Test2::Require"; + +like( + dies { Test2::Require->skip() }, + qr/Class 'Test2::Require' needs to implement 'skip\(\)'/, + "skip must be overriden" +); + +my $x; + +{ + package Require::Foo; + use base 'Test2::Require'; + sub skip { $x } +} + +my $events = intercept { + $x = undef; + Require::Foo->import(); + ok(1, 'pass'); +}; + +like( + $events, + array { + event Ok => {pass => 1, name => 'pass'}; + }, + "Did not skip all" +); + +$events = intercept { + $x = "This should skip"; + Require::Foo->import(); + die "Should not get here"; +}; + +like( + $events, + array { + event Plan => { + max => 0, + directive => 'SKIP', + reason => 'This should skip', + }; + }, + "Skipped all" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require/AuthorTesting.t b/cpan/Test2-Suite/t/modules/Require/AuthorTesting.t new file mode 100644 index 000000000000..03011b181416 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require/AuthorTesting.t @@ -0,0 +1,12 @@ +use Test2::Bundle::Extended -target => 'Test2::Require::AuthorTesting'; + +{ + local %ENV = %ENV; + $ENV{AUTHOR_TESTING} = 0; + is($CLASS->skip(), 'Author test, set the $AUTHOR_TESTING environment variable to run it', "will skip"); + + $ENV{AUTHOR_TESTING} = 1; + is($CLASS->skip(), undef, "will not skip"); +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require/EnvVar.t b/cpan/Test2-Suite/t/modules/Require/EnvVar.t new file mode 100644 index 000000000000..0407a76d4d05 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require/EnvVar.t @@ -0,0 +1,18 @@ +use Test2::Bundle::Extended -target => 'Test2::Require::EnvVar'; + +{ + local %ENV = %ENV; + $ENV{FOO} = 0; + is($CLASS->skip('FOO'), 'This test only runs if the $FOO environment variable is set', "will skip"); + + $ENV{FOO} = 1; + is($CLASS->skip('FOO'), undef, "will not skip"); + + like( + dies { $CLASS->skip }, + qr/no environment variable specified/, + "must specify a var" + ); +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require/Fork.t b/cpan/Test2-Suite/t/modules/Require/Fork.t new file mode 100644 index 000000000000..01e18df705e2 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require/Fork.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +# Prevent Test2::Util from making 'CAN_FORK' a constant +my $forks; +BEGIN { + require Test2::Util; + local $SIG{__WARN__} = sub { 1 }; # no warnings is not sufficient on older perls + *Test2::Util::CAN_FORK = sub { $forks }; +} + +use Test2::Bundle::Extended -target => 'Test2::Require::Fork'; + +{ + $forks = 0; + is($CLASS->skip(), 'This test requires a perl capable of forking.', "will skip"); + + $forks = 1; + is($CLASS->skip(), undef, "will not skip"); +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require/Module.t b/cpan/Test2-Suite/t/modules/Require/Module.t new file mode 100644 index 000000000000..909e29d60768 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require/Module.t @@ -0,0 +1,18 @@ +use Test2::Bundle::Extended -target => 'Test2::Require::Module'; + +is($CLASS->skip('Scalar::Util'), undef, "will not skip, module installed"); +is($CLASS->skip('Scalar::Util', 0.5), undef, "will not skip, module at sufficient version"); + +like( + $CLASS->skip('Test2', '99999'), + qr/Need 'Test2' version 99999, have \d+.\d+\./, + "Skip, insufficient version" +); + +is( + $CLASS->skip('Some::Fake::Module'), + "Module 'Some::Fake::Module' is not installed", + "Skip, not installed" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require/Perl.t b/cpan/Test2-Suite/t/modules/Require/Perl.t new file mode 100644 index 000000000000..e0a9f2a29e68 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require/Perl.t @@ -0,0 +1,6 @@ +use Test2::Bundle::Extended -target => 'Test2::Require::Perl'; + +is($CLASS->skip('v5.6'), undef, "will not skip"); +is($CLASS->skip('v10.10'), 'Perl v10.10.0 required', "will skip"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require/RealFork.t b/cpan/Test2-Suite/t/modules/Require/RealFork.t new file mode 100644 index 000000000000..fc9b56580109 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require/RealFork.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +# Prevent Test2::Util from making 'CAN_REALLY_FORK' a constant +my $forks; +BEGIN { + require Test2::Util; + local $SIG{__WARN__} = sub { 1 }; # no warnings is not sufficient on older perls + *Test2::Util::CAN_REALLY_FORK = sub { $forks }; +} + +use Test2::Bundle::Extended -target => 'Test2::Require::RealFork'; + +{ + $forks = 0; + is($CLASS->skip(), 'This test requires a perl capable of true forking.', "will skip"); + + $forks = 1; + is($CLASS->skip(), undef, "will not skip"); +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Require/Threads.t b/cpan/Test2-Suite/t/modules/Require/Threads.t new file mode 100644 index 000000000000..fb912237d16c --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Require/Threads.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +# Prevent Test2::Util from making 'CAN_THREAD' a constant +my $threads; +BEGIN { + require Test2::Util; + local $SIG{__WARN__} = sub { 1 }; # no warnings is not sufficient on older perls + *Test2::Util::CAN_THREAD = sub { $threads }; +} + +use Test2::Bundle::Extended -target => 'Test2::Require::Threads'; + +{ + $threads = 0; + is($CLASS->skip(), 'This test requires a perl capable of threading.', "will skip"); + + $threads = 1; + is($CLASS->skip(), undef, "will not skip"); +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Suite.t b/cpan/Test2-Suite/t/modules/Suite.t new file mode 100644 index 000000000000..77a6c8e66c5d --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Suite.t @@ -0,0 +1,9 @@ +use Test2::Bundle::Extended; + +use Test2::Suite; + +pass("Loaded Test2::Suite"); + +ok($Test2::Suite::VERSION, "have a version"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Todo.t b/cpan/Test2-Suite/t/modules/Todo.t new file mode 100644 index 000000000000..060fe2effc69 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Todo.t @@ -0,0 +1,59 @@ +use Test2::Bundle::Extended -target => 'Test2::Todo'; + +my $todo = Test2::Todo->new(reason => 'xyz'); +def isa_ok => ($todo, $CLASS); +def ok => ((grep {$_->{code} == $todo->_filter} @{Test2::API::test2_stack->top->_pre_filters}), "filter added"); +def is => ($todo->reason, 'xyz', "got reason"); +def ref_is => ($todo->hub, Test2::API::test2_stack->top, "used current hub"); +def ok => (my $filter = $todo->_filter, "stored filter"); +$todo->end; + +do_def; +ok(!(grep {$_->{code} == $filter} @{Test2::API::test2_stack->top->_pre_filters}), "filter removed"); + +my $ok = Test2::Event::Ok->new(pass => 0, name => 'xxx'); +my $diag = Test2::Event::Diag->new(message => 'xxx'); + +ok(!$ok->todo, "ok is not TODO"); +ok(!$ok->effective_pass, "not effectively passing"); +my $filtered_ok = $filter->(Test2::API::test2_stack->top, $ok); +is($filtered_ok->todo, 'xyz', "the ok is now todo"); +ok($filtered_ok->effective_pass, "now effectively passing"); + +isa_ok($diag, 'Test2::Event::Diag'); +my $filtered_diag = $filter->(Test2::API::test2_stack->top, $diag); +isa_ok($filtered_diag, 'Test2::Event::Note'); +is($filtered_diag->message, $diag->message, "new note has the same message"); + +my $events = intercept { + ok(0, 'fail'); + + my $todo = Test2::Todo->new(reason => 'xyz'); + ok(0, 'todo fail'); + $todo = undef; + + ok(0, 'fail'); +}; + +like( + $events, + array { + event Ok => { pass => 0, effective_pass => 0, todo => DNE }; + event Diag => {}; + + event Ok => { pass => 0, effective_pass => 1, todo => 'xyz' }; + event Note => {}; + + event Ok => { pass => 0, effective_pass => 0, todo => DNE }; + event Diag => {}; + }, + "Got expected events" +); + +$todo = $CLASS->new(reason => 'this is a todo'); +$todo->end; + +is("$todo", 'this is a todo', "Stringify's to the reason"); +ok($todo eq 'this is a todo', "String comparison works"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools.t b/cpan/Test2-Suite/t/modules/Tools.t new file mode 100644 index 000000000000..0dbc6d3ddb14 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools.t @@ -0,0 +1,7 @@ +use Test2::Bundle::Extended; + +use Test2::Tools; + +pass("Loaded Test2::Tools"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/AsyncSubtest.t b/cpan/Test2-Suite/t/modules/Tools/AsyncSubtest.t new file mode 100644 index 000000000000..9a357a099747 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/AsyncSubtest.t @@ -0,0 +1,74 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::AsyncSubtest'; +use Test2::Tools::AsyncSubtest; +use Test2::Util qw/get_tid CAN_REALLY_FORK/; +use Test2::API qw/intercept/; + +sub DO_THREADS { + return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; + return Test2::AsyncSubtest->CAN_REALLY_THREAD; +} + +ok($INC{'Test2/IPC.pm'}, "Loaded Test2::IPC"); + +imported_ok(qw/async_subtest fork_subtest thread_subtest/); + +sub run { + my $ast = async_subtest('foo'); + $ast->run(sub { ok(1, "inside subtest") }); + $ast->finish; + + $ast = async_subtest foo => sub { ok(1, "inside subtest") }; + $ast->finish; + + if (CAN_REALLY_FORK) { + $ast = fork_subtest foo => sub { ok(1, "forked subtest: $$") }; + $ast->finish; + } + + if (DO_THREADS()) { + $ast = thread_subtest foo => sub { ok(1, "threaded subtest: " . get_tid) }; + $ast->finish; + } +} + +run(); + +is( + &intercept(\&run), + array { + event Subtest => sub { + call pass => T; + call name => 'foo'; + call subevents => array { + event Ok => { pass => 1 }; + event Plan => { max => 1 }; + }; + } for 1 .. 2; + + event Subtest => sub { + call pass => T; + call name => 'foo'; + call subevents => array { + event '+Test2::AsyncSubtest::Event::Attach' => {}; + event Ok => { pass => 1 }; + event '+Test2::AsyncSubtest::Event::Detach' => {}; + event Plan => { max => 1 }; + }; + } for grep { $_ } CAN_REALLY_FORK, DO_THREADS(); + }, + "Got expected events" +); + +like( + dies { fork_subtest('foo') }, + qr/fork_subtest requires a CODE reference as the second argument/, + "fork_subtest needs code" +); + +like( + dies { thread_subtest('foo') }, + qr/thread_subtest requires a CODE reference as the second argument/, + "thread_subtest needs code" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Basic.t b/cpan/Test2-Suite/t/modules/Tools/Basic.t new file mode 100644 index 000000000000..c966def624d0 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Basic.t @@ -0,0 +1,304 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Basic'; + +{ + package Temp; + use Test2::Tools::Basic; + + main::imported_ok(qw{ + ok pass fail diag note todo skip + plan skip_all done_testing bail_out + }); +} + +pass('Testing Pass'); + +my @lines; +like( + intercept { + pass('pass'); push @lines => __LINE__; + fail('fail'); push @lines => __LINE__; + fail('fail', 'added diag'); push @lines => __LINE__; + }, + array { + event Ok => sub { + call pass => 1; + call name => 'pass'; + + prop file => __FILE__; + prop package => __PACKAGE__; + prop line => $lines[0]; + prop subname => 'Test2::Tools::Basic::pass'; + }; + + event Ok => sub { + call pass => 0; + call name => 'fail'; + + prop file => __FILE__; + prop package => __PACKAGE__; + prop line => $lines[1]; + prop subname => 'Test2::Tools::Basic::fail'; + }; + event Diag => sub { + call message => qr/Failed test 'fail'.*line $lines[1]/s; + + prop file => __FILE__; + prop package => __PACKAGE__; + prop line => $lines[1]; + prop subname => 'Test2::Tools::Basic::fail'; + }; + + event Ok => sub { + call pass => 0; + call name => 'fail'; + + prop file => __FILE__; + prop package => __PACKAGE__; + prop line => $lines[2]; + prop subname => 'Test2::Tools::Basic::fail'; + }; + event Diag => sub { + call message => qr/Failed test 'fail'.*line $lines[2]/s; + + prop file => __FILE__; + prop package => __PACKAGE__; + prop line => $lines[2]; + prop subname => 'Test2::Tools::Basic::fail'; + }; + event Diag => sub { + call message => 'added diag'; + + prop file => __FILE__; + prop package => __PACKAGE__; + prop line => $lines[2]; + prop subname => 'Test2::Tools::Basic::fail'; + }; + + end; + }, + "Got expected events for 'pass' and 'fail'" +); + +ok(1, 'Testing ok'); + +@lines = (); +like( + intercept { + ok(1, 'pass', 'invisible diag'); push @lines => __LINE__; + ok(0, 'fail'); push @lines => __LINE__; + ok(0, 'fail', 'added diag'); push @lines => __LINE__; + }, + array { + event Ok => sub { + call pass => 1; + call name => 'pass'; + prop line => $lines[0]; + }; + + event Ok => sub { + call pass => 0; + call name => 'fail'; + prop debug => 'at ' . __FILE__ . " line $lines[1]"; + }; + event Diag => sub { + call message => qr/Failed test 'fail'.*line $lines[1]/s; + prop debug => 'at ' . __FILE__ . " line $lines[1]"; + }; + + event Ok => sub { + call pass => 0; + call name => 'fail'; + prop debug => 'at ' . __FILE__ . " line $lines[2]"; + }; + event Diag => sub { + call message => qr/Failed test 'fail'.*line $lines[2]/s; + prop debug => 'at ' . __FILE__ . " line $lines[2]"; + }; + event Diag => sub { + call message => 'added diag'; + prop debug => 'at ' . __FILE__ . " line $lines[2]"; + }; + + end; + }, + "Got expected events for 'ok'" +); + +diag "Testing Diag (AUTHOR_TESTING ONLY)" if $ENV{AUTHOR_TESTING}; + +like( + intercept { + diag "foo"; + diag "foo", ' ', "bar"; + }, + array { + event Diag => { message => 'foo' }; + event Diag => { message => 'foo bar' }; + }, + "Got expected events for diag" +); + +note "Testing Note"; + +like( + intercept { + note "foo"; + note "foo", ' ', "bar"; + }, + array { + event Note => { message => 'foo' }; + event Note => { message => 'foo bar' }; + }, + "Got expected events for note" +); + +like( + intercept { + bail_out 'oops'; + # Should not get here + print STDERR "Something is wrong, did not bail out!\n"; + exit 255; + }, + array { + event Bail => { reason => 'oops' }; + end; + }, + "Got bail event" +); + +like( + intercept { + skip_all 'oops'; + # Should not get here + print STDERR "Something is wrong, did not skip!\n"; + exit 255; + }, + array { + event Plan => { max => 0, directive => 'SKIP', reason => 'oops' }; + end; + }, + "Got plan (skip_all) event" +); + +like( + intercept { + plan skip_all => 'oops'; + # Should not get here + print STDERR "Something is wrong, did not skip!\n"; + exit 255; + }, + array { + event Plan => { max => 0, directive => 'SKIP', reason => 'oops' }; + end; + }, + "Got plan 'skip_all' prefix" +); + + +like( + intercept { + plan(5); + }, + array { + event Plan => { max => 5 }; + end; + }, + "Got plan" +); + +like( + intercept { + plan(tests => 5); + }, + array { + event Plan => { max => 5 }; + end; + }, + "Got plan 'tests' prefix" +); + + +like( + intercept { + ok(1); + ok(2); + done_testing; + }, + array { + event Ok => { pass => 1 }; + event Ok => { pass => 1 }; + event Plan => { max => 2 }; + end; + }, + "Done Testing works" +); + +like( + intercept { + ok(0, "not todo"); + + { + my $todo = todo('todo 1'); + ok(0, 'todo fail'); + } + + ok(0, "not todo"); + + my $todo = todo('todo 2'); + ok(0, 'todo fail'); + $todo = undef; + + ok(0, "not todo"); + + todo 'todo 3' => sub { + ok(0, 'todo fail'); + }; + + ok(0, "not todo"); + }, + array { + for my $id (1 .. 3) { + event Ok => sub { + call pass => 0; + call effective_pass => 0; + call todo => undef; + }; + event Diag => { message => qr/Failed/ }; + + event Ok => sub { + call pass => 0; + call effective_pass => 1; + call todo => "todo $id"; + }; + event Note => { message => qr/Failed/ }; + } + event Ok => { pass => 0, effective_pass => 0 }; + event Diag => { message => qr/Failed/ }; + end; + }, + "Got todo events" +); + +like( + intercept { + ok(1, 'pass'); + SKIP: { + skip 'oops' => 5; + + ok(1, "Should not see this"); + } + }, + array { + event Ok => { pass => 1 }; + + event Skip => sub { + call pass => 1; + call reason => 'oops'; + } for 1 .. 5; + + end; + }, + "got skip events" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Class.t b/cpan/Test2-Suite/t/modules/Tools/Class.t new file mode 100644 index 000000000000..79b49923ad61 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Class.t @@ -0,0 +1,152 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Class'; + +{ + package Temp; + use Test2::Tools::Class; + + main::imported_ok(qw/can_ok isa_ok DOES_ok/); +} + +{ + package X; + + sub can { + my $thing = pop; + return 1 if $thing =~ m/x/; + return 1 if $thing eq 'DOES'; + } + + sub isa { + my $thing = pop; + return 1 if $thing =~ m/x/; + } + + sub DOES { + my $thing = pop; + return 1 if $thing =~ m/x/; + } +} + +{ + package XYZ; + use Carp qw/croak/; + sub isa { croak 'oops' }; + sub can { croak 'oops' }; + sub DOES { croak 'oops' }; +} + +{ + package My::String; + use overload '""' => sub { "xxx\nyyy" }; + + sub DOES { 0 } +} + +like( + intercept { + my $str = bless {}, 'My::String'; + + isa_ok('X', qw/axe box fox/); + can_ok('X', qw/axe box fox/); + DOES_ok('X', qw/axe box fox/); + isa_ok($str, 'My::String'); + + isa_ok('X', qw/foo bar axe box/); + can_ok('X', qw/foo bar axe box/); + DOES_ok('X', qw/foo bar axe box/); + + isa_ok($str, 'X'); + can_ok($str, 'X'); + DOES_ok($str, 'X'); + + isa_ok(undef, 'X'); + isa_ok('', 'X'); + isa_ok({}, 'X'); + + isa_ok('X', [qw/axe box fox/], 'alt name'); + can_ok('X', [qw/axe box fox/], 'alt name'); + DOES_ok('X', [qw/axe box fox/], 'alt name'); + + isa_ok('X', [qw/foo bar axe box/], 'alt name'); + can_ok('X', [qw/foo bar axe box/], 'alt name'); + DOES_ok('X', [qw/foo bar axe box/], 'alt name'); + }, + array { + event Ok => { pass => 1, name => 'X->isa(...)' }; + event Ok => { pass => 1, name => 'X->can(...)' }; + event Ok => { pass => 1, name => 'X->DOES(...)' }; + event Ok => { pass => 1, name => qr/My::String=.*->isa\('My::String'\)/ }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => {message => "Failed: X->isa('foo')"}; + event Diag => {message => "Failed: X->isa('bar')"}; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "Failed: X->can('foo')" }; + event Diag => { message => "Failed: X->can('bar')" }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "Failed: X->DOES('foo')" }; + event Diag => { message => "Failed: X->DOES('bar')" }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => qr/Failed: My::String=HASH->isa\('X'\)/ }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => qr/Failed: My::String=HASH->can\('X'\)/ }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => qr/Failed: My::String=HASH->DOES\('X'\)/ }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => qr/ is neither a blessed reference or a package name/ }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => qr/'' is neither a blessed reference or a package name/ }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => qr/HASH is neither a blessed reference or a package name/ }; + + event Ok => { pass => 1, name => 'alt name' }; + event Ok => { pass => 1, name => 'alt name' }; + event Ok => { pass => 1, name => 'alt name' }; + + fail_events Ok => sub { call pass => 0; call name => 'alt name' }; + event Diag => {message => "Failed: X->isa('foo')"}; + event Diag => {message => "Failed: X->isa('bar')"}; + fail_events Ok => sub { call pass => 0; call name => 'alt name' }; + event Diag => {message => "Failed: X->can('foo')"}; + event Diag => {message => "Failed: X->can('bar')"}; + fail_events Ok => sub { call pass => 0; call name => 'alt name' }; + event Diag => {message => "Failed: X->DOES('foo')"}; + event Diag => {message => "Failed: X->DOES('bar')"}; + + end; + }, + "'can/isa/DOES_ok' events" +); + +my $override = UNIVERSAL->can('DOES') ? 1 : 0; +note "Will override UNIVERSAL::can to hide 'DOES'" if $override; + +my $events = intercept { + my $can = \&UNIVERSAL::can; + + # If the platform does support 'DOES' lets pretend it doesn't. + no warnings 'redefine'; + local *UNIVERSAL::can = sub { + my ($thing, $sub) = @_; + return undef if $sub eq 'DOES'; + $thing->$can($sub); + } if $override; + + DOES_ok('A::Fake::Package', 'xxx'); +}; + +like( + $events, + array { + event Skip => { + pass => 1, + name => "A::Fake::Package->DOES('xxx')", + reason => "'DOES' is not supported on this platform", + }; + }, + "Test us skipped when platform does not support 'DOES'" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/ClassicCompare.t b/cpan/Test2-Suite/t/modules/Tools/ClassicCompare.t new file mode 100644 index 000000000000..4451112f15f4 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/ClassicCompare.t @@ -0,0 +1,343 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::ClassicCompare'; + +BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } + +use Test2::Util::Stash qw/purge_symbol/; +BEGIN { + purge_symbol('&is'); + purge_symbol('&like'); + purge_symbol('&unlike'); + purge_symbol('&isnt'); + purge_symbol('&cmp_ok'); + + not_imported_ok(qw/is is_deeply like unlike isnt cmp_ok/); +} + +use Test2::Tools::ClassicCompare; + +imported_ok(qw/is is_deeply like cmp_ok unlike isnt/); + +my $ref = {}; + +is(undef, undef, "undef is undef"); + +is("foo", "foo", 'foo check'); +is($ref, "$ref", "flat check, ref as string right"); +is("$ref", $ref, "flat check, ref as string left"); + +isnt("bar", "foo", 'not foo check'); +isnt({}, "$ref", "negated flat check, ref as string right"); +isnt("$ref", {}, "negated flat check, ref as string left"); + +like('aaa', qr/a/, "have an a"); +like('aaa', 'a', "have an a, not really a regex"); + +unlike('bbb', qr/a/, "do not have an a"); +unlike('bbb', 'a', "do not have an a, not really a regex"); + +# Failures +my $events = intercept { + def ok => (!is('foo', undef, "undef check"), "undef check"); + def ok => (!is(undef, 'foo', "undef check"), "undef check"); + def ok => (!is('foo', 'bar', "string mismatch"), "string mismatch"); + def ok => (!isnt('foo', 'foo', "undesired match"), "undesired match"); + def ok => (!like('foo', qr/a/, "no match"), "no match"); + def ok => (!unlike('foo', qr/o/, "unexpected match"), "unexpected match"); +}; + +do_def; + +is_deeply( + $events, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => { }; + event Fail => { }; + event Fail => { }; + event Fail => { }; + event Fail => { }; + event Fail => { }; + end; + }, + "got failure events" +); + +# is_deeply uses the same algorithm as the 'Compare' plugin, so it is already +# tested over there. +is_deeply( + {foo => 1, bar => 'baz'}, + {foo => 1, bar => 'baz'}, + "Deep compare" +); + +{ + package Foo; + use overload '""' => sub { 'xxx' }; +} +my $foo = bless({}, 'Foo'); +like($foo, qr/xxx/, "overload"); + +my $thing = bless {}, 'Foo::Bar'; + +# Test cmp_ok in a seperate package so we have access to the better tools. +package main2; + +use Test2::Bundle::Extended; +BEGIN { main::purge_symbol('&cmp_ok') } +use Test2::Tools::ClassicCompare qw/cmp_ok/; +use Test2::Util::Table(); +sub table { join "\n" => Test2::Util::Table::table(@_) } +use Test2::Util::Ref qw/render_ref/; + +cmp_ok('x', 'eq', 'x', 'string pass'); +cmp_ok(5, '==', 5, 'number pass'); +cmp_ok(5, '==', 5.0, 'float pass'); + +my $file = __FILE__; +my $line = __LINE__ + 2; +like( + warnings { cmp_ok(undef, '==', undef, 'undef pass') }, + [ + qr/uninitialized value.*at \(eval in cmp_ok\) \Q$file\E line $line/, + ], + "got expected warnings (number)" +); + +$line = __LINE__ + 2; +like( + warnings { cmp_ok(undef, 'eq', undef, 'undef pass') }, + [ + qr/uninitialized value.*at \(eval in cmp_ok\) \Q$file\E line $line/, + ], + "got expected warnings (string)" +); + +like( + intercept { cmp_ok('x', 'ne', 'x', 'string fail', 'extra diag') }, + array { + fail_events Ok => sub { + call pass => 0; + call name => 'string fail'; + }; + event Diag => sub { + call message => table( + header => [qw/GOT OP CHECK/], + rows => [ + [qw/x ne x/], + ], + ); + }; + event Diag => { message => 'extra diag' }; + end; + }, + "Got 1 string fail event" +); + +like( + intercept { cmp_ok(5, '==', 42, 'number fail', 'extra diag') }, + array { + fail_events Ok => sub { + call pass => 0; + call name => 'number fail'; + }; + event Diag => sub { + call message => table( + header => [qw/GOT OP CHECK/], + rows => [ + [qw/5 == 42/], + ], + ); + }; + event Diag => { message => 'extra diag' }; + + end; + }, + "Got 1 number fail event" +); + +my $warning; +$line = __LINE__ + 2; +like( + intercept { $warning = main::warning { cmp_ok(5, '&& die', 42, 'number fail', 'extra diag') } }, + array { + event Exception => { error => qr/42 at \(eval in cmp_ok\) \Q$file\E line $line/ }; + fail_events Ok => sub { + call pass => 0; + call name => 'number fail'; + }; + + event Diag => sub { + call message => table( + header => [qw/GOT OP CHECK/], + rows => [ + ['5', '&& die', ''], + ], + ); + }; + event Diag => { message => 'extra diag' }; + + end; + }, + "Got exception in test" +); +like( + $warning, + qr/operator '&& die' is not supported \(you can add it to %Test2::Tools::ClassicCompare::OPS\)/, + "Got warning about unsupported operator" +); + +{ + package Overloaded::Foo42; + use overload + 'fallback' => 1, + '0+' => sub { 42 }, + '""' => sub { 'foo' }; +} + +$foo = bless {}, 'Overloaded::Foo42'; + +cmp_ok($foo, '==', 42, "numeric compare with overloading"); +cmp_ok($foo, 'eq', 'foo', "string compare with overloading"); + +like( + intercept { + local $ENV{TS_TERM_SIZE} = 10000; + cmp_ok($foo, 'ne', $foo, 'string fail', 'extra diag') + }, + array { + fail_events Ok => sub { + call pass => 0; + call name => 'string fail'; + }; + + event Diag => sub { + call message => table( + header => [qw/TYPE GOT OP CHECK/], + rows => [ + ['str', 'foo', 'ne', 'foo'], + ['orig', render_ref($foo), '', render_ref($foo)], + ], + ); + }; + event Diag => { message => 'extra diag' }; + + end; + }, + "Failed string compare, overload" +); + +like( + intercept { + local $ENV{TS_TERM_SIZE} = 10000; + cmp_ok($foo, '!=', $foo, 'number fail', 'extra diag') + }, + array { + fail_events Ok => sub { + call pass => 0; + call name => 'number fail'; + }; + + event Diag => sub { + call message => table( + header => [qw/TYPE GOT OP CHECK/], + rows => [ + ['num', '42', '!=', '42'], + ['orig', render_ref($foo), '', render_ref($foo)], + ], + ); + }; + event Diag => { message => 'extra diag' }; + + end; + }, + "Failed number compare, overload" +); + +$line = __LINE__ + 2; +like( + intercept { + local $ENV{TS_TERM_SIZE} = 10000; + main::warning { + cmp_ok($foo, '&& die', $foo, 'overload exception', 'extra diag') + } + }, + array { + event Exception => { error => T() }; + fail_events Ok => sub { + call pass => 0; + call name => 'overload exception'; + }; + + event Diag => sub { + call message => table( + header => [qw/TYPE GOT OP CHECK/], + rows => [ + ['unsupported', 'foo', '&& die', ''], + ['orig', render_ref($foo), '', render_ref($foo)], + ], + ); + }; + event Diag => { message => 'extra diag' }; + + end; + }, + "Got exception in test" +); + + +note "cmp_ok() displaying good numbers"; { + my $have = 1.23456; + my $want = 4.5678; + like( + intercept { + cmp_ok($have, '>', $want); + }, + array { + fail_events Ok => sub { + call pass => 0; + }; + + event Diag => sub { + call message => table( + header => [qw/GOT OP CHECK/], + rows => [ + [$have, '>', $want], + ], + ); + }; + + end; + }, + ); +} + + +note "cmp_ok() displaying bad numbers"; { + my $have = "zero"; + my $want = "3point5"; + like( + intercept { + warnings { cmp_ok($have, '>', $want) }; + }, + array { + fail_events Ok => sub { + call pass => 0; + }; + + event Diag => sub { + call message => table( + header => [qw/TYPE GOT OP CHECK/], + rows => [ + ['num', 0, '>', '3'], + ['orig', $have, '', $want], + ], + ); + }; + + end; + }, + ); +} + + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/ClassicCompare2.t b/cpan/Test2-Suite/t/modules/Tools/ClassicCompare2.t new file mode 100644 index 000000000000..945170759459 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/ClassicCompare2.t @@ -0,0 +1,4 @@ +use Test2::Tools::ClassicCompare; +use Test2::Tools::Basic; +is_deeply({},{}, "deep checking works"); +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Compare.t b/cpan/Test2-Suite/t/modules/Tools/Compare.t new file mode 100644 index 000000000000..a22b817858ea --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Compare.t @@ -0,0 +1,1961 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Compare'; +use Test2::Util::Table(); + +BEGIN { + $ENV{TABLE_TERM_SIZE} = 80; + $ENV{T2_AUTO_DUMP} = 0; + $ENV{T2_AUTO_DEPARSE} = 0; +} + +{ + package My::Boolean; + use overload bool => sub { ${$_[0]} }; +} + +{ + package My::String; + use overload '""' => sub { "xxx" }; +} + +sub fail_table { + my %args = @_; + + my $string = join "\n" => Test2::Util::Table::table(%args, sanitize => 1, mark_tail => 1); + + event Fail => sub { + call facet_data => hash { + field assert => hash { field pass => 0; etc }; + field info => array { + item hash { + field details => match(qr/^\Q$string\E/); + field table => hash { + field header => bag { item $_ for @{$args{header}}; etc }; + field rows => bag { + item bag { item $_ for @{$_}; etc } for @{$args{rows}}; + etc; + }; + etc; + }; + etc; + }; + etc; + }; + etc; + }; + }; +} + +subtest simple => sub { + imported_ok qw{ + match mismatch validator + hash array bag object meta number float rounded within string bool + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event + exact_ref + }; +}; + +subtest is => sub { + my $events = intercept { + def ok => (is(1, 1), '2 arg pass'); + + def ok => (is('a', 'a', "simple pass", 'diag'), 'simple pass'); + def ok => (!is('a', 'b', "simple fail", 'diag'), 'simple fail'); + + def ok => (is([{'a' => 1}], [{'a' => 1}], "complex pass", 'diag'), 'complex pass'); + def ok => (!is([{'a' => 2, 'b' => 3}], [{'a' => 1}], "complex fail", 'diag'), 'complex fail'); + + def ok => (is(undef, undef), 'undef pass'); + def ok => (!is(0, undef), 'undef fail'); + + my $true = do { bless \(my $dummy = 1), "My::Boolean" }; + my $false = do { bless \(my $dummy = 0), "My::Boolean" }; + def ok => (is($true, $true, "true scalar ref is itself"), "true scalar ref is itself"); + def ok => (is($false, $false, "false scalar ref is itself"), "false scalar ref is itself"); + + def ok => (is(v1.2.3, v1.2.3, 'vstring pass'), 'vstring pass'); + def ok => (is(\v1.2.3, \v1.2.3, 'vstring refs pass'), 'vstring refs pass'); + def ok => (!is(v1.2.3, v1.2.4, 'vstring fail'), 'vstring fail'); + def ok => (!is(\v1.2.3, \v1.2.4, 'vstring refs fail'), 'vstring refs fail'); + + my $x = \\"123"; + def ok => (is($x, \\"123", "Ref-Ref check 1"), "Ref-Ref check 1"); + + $x = \[123]; + def ok => (is($x, \["123"], "Ref-Ref check 2"), "Ref-Ref check 2"); + + def ok => (!is(\$x, \\["124"], "Ref-Ref check 3"), "Ref-Ref check 3"); + }; + + do_def; + + like( + $events, + array { + event Ok => sub { + call pass => T(); + call name => undef; + }; + + event Ok => sub { + call pass => T(); + call name => 'simple pass'; + }; + + fail_table( + header => [qw/GOT OP CHECK/], + rows => [[qw/a eq b/]], + ); + + event Ok => sub { + call pass => T(); + call name => 'complex pass'; + }; + + fail_table( + header => [qw/PATH GOT OP CHECK/], + rows => [ + [qw/[0]{a} 2 eq 1/], + [qw/[0]{b} 3 !exists/, ''], + ], + ); + + event Ok => sub { + call pass => T(); + }; + + fail_table( + header => [qw/GOT OP CHECK/], + rows => [[qw/0 IS /]], + ); + + event Ok => sub { + call pass => T(); + call name => "true scalar ref is itself"; + }; + + event Ok => sub { + call pass => T(); + call name => "false scalar ref is itself"; + }; + + event Ok => sub { + call pass => T(); + call name => 'vstring pass'; + }; + + event Ok => sub { + call pass => T(); + call name => 'vstring refs pass'; + }; + + fail_table( + header => [qw/GOT OP CHECK/], + rows => [["\N{U+1}\N{U+2}\N{U+3}", 'eq', "\N{U+1}\N{U+2}\N{U+4}"]], + ); + + fail_table( + header => [qw/PATH GOT OP CHECK/], + rows => [['$*', "\N{U+1}\N{U+2}\N{U+3}", 'eq', "\N{U+1}\N{U+2}\N{U+4}"]], + ); + + event Ok => sub { + call pass => T(); + call name => "Ref-Ref check 1"; + }; + + event Ok => sub { + call pass => T(); + call name => "Ref-Ref check 2"; + }; + + event Fail => sub { + call name => 'Ref-Ref check 3'; + }; + + end; + }, + "Got expected events" + ); + + $events = intercept { is({foo => {bar => 'a'}, a => 1}, {foo => {baz => 'a'}, a => 2}, "Typo") }; + chomp(my $want = <<" EOT"); ++------------+------------------+---------+------------------+ +| PATH | GOT | OP | CHECK | ++------------+------------------+---------+------------------+ +| {a} | 1 | eq | 2 | +| {foo}{baz} | | | a | +| {foo}{bar} | a | !exists | | ++------------+------------------+---------+------------------+ +==== Summary of missing/extra items ==== +{foo}{baz}: DOES NOT EXIST +{foo}{bar}: SHOULD NOT EXIST +== end summary of missing/extra items == + EOT + + like( + $events->[0]->facet_data->{info}->[0]->{details}, + $want, + "Got summary of missing/extra" + ); +}; + +subtest like => sub { + my $events = intercept { + def ok => (like(1, 1), '2 arg pass'); + + def ok => (like('a', qr/a/, "simple pass", 'diag'), 'simple pass'); + def ok => (!like('b', qr/a/, "simple fail", 'diag'), 'simple fail'); + + def ok => (like([{'a' => 1, 'b' => 2}, 'a'], [{'a' => 1}], "complex pass", 'diag'), 'complex pass'); + def ok => (!like([{'a' => 2, 'b' => 2}, 'a'], [{'a' => 1}], "complex fail", 'diag'), 'complex fail'); + + my $str = bless {}, 'My::String'; + def ok => (like($str, qr/xxx/, 'overload pass'), "overload pass"); + def ok => (!like($str, qr/yyy/, 'overload fail'), "overload fail"); + + }; + + do_def; + + my $rx = "" . qr/a/; + + like( + $events, + array { + event Ok => sub { + call pass => T(); + call name => undef; + }; + + event Ok => sub { + call pass => T(); + call name => 'simple pass'; + }; + + fail_table( + header => [qw/GOT OP CHECK/], + rows => [[qw/b =~/, "$rx"]], + ); + + event Ok => sub { + call pass => T(); + call name => 'complex pass'; + }; + + fail_table( + header => [qw/PATH GOT OP CHECK/], + rows => [[qw/[0]{a} 2 eq 1/]], + ); + + event Ok => sub { + call pass => T(); + call name => 'overload pass'; + }; + + $rx = qr/yyy/; + fail_table( + header => [qw/GOT OP CHECK/], + rows => [[qw/xxx =~/, "$rx"]], + ); + + end; + }, + "Got expected events" + ); +}; + +subtest shortcuts => sub { + is(1, T(), "true"); + is('a', T(), "true"); + is(' ', T(), "true"); + is('0 but true', T(), "true"); + + my @lines; + my $events = intercept { + is(0, T(), "not true"); push @lines => __LINE__; + is('', T(), "not true"); push @lines => __LINE__; + is(undef, T(), "not true"); push @lines => __LINE__; + }; + like( + $events, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => sub { prop line => $lines[0]; prop file => __FILE__; }; + event Fail => sub { prop line => $lines[1]; prop file => __FILE__; }; + event Fail => sub { prop line => $lines[2]; prop file => __FILE__; }; + end() + }, + "T() fails for untrue", + ); + + is(0, F(), "false"); + is('', F(), "false"); + is(undef, F(), "false"); + + $events = intercept { + is(1, F(), "not false"); + is('a', F(), "not false"); + is(' ', F(), "not false"); + }; + like( + $events, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + event Fail => {}; + end() + }, + "F() fails for true", + ); + + is(undef, U(), "not defined"); + + like( + intercept { is(0, U(), "not defined") }, + array { event Fail => {} }, + "0 is defined" + ); + + is(0, D(), "defined"); + is(1, D(), "defined"); + is('', D(), "defined"); + is(' ', D(), "defined"); + is('0 but true', D(), "defined"); + + like( + intercept { is(undef, D(), "not defined") }, + array { event Fail => { } }, + "undef is not defined" + ); + + is(0, DF(), "defined but false"); + is('', DF(), "defined but false"); + + like( + intercept { + is(undef, DF()); + is(1, DF()); + is(' ', DF()); + is('0 but true', DF()); + }, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + event Fail => {}; + event Fail => {}; + }, + "got fail for DF" + ); + + is([undef], [E()], "does exist"); + is([], [DNE()], "does not exist"); + is({}, {a => DNE()}, "does not exist"); + $events = intercept { + is([], [E()]); + is([undef], [DNE()]); + is({a => undef}, {a => DNE()}); + }; + like( + $events, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + event Fail => {}; + }, + "got failed event" + ); + + is([], [FDNE()], "does not exist"); + is({}, {a => FDNE()}, "does not exist"); + is([undef], [FDNE()], "false"); + is({a => undef}, {a => FDNE()}, "false"); + + $events = intercept { + is([1], [FDNE()]); + is({a => 1}, {a => FDNE()}); + }; + like( + $events, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + }, + "got failed event" + ); + + is('foo', L(), "defined and has length"); + is(0, L(), "defined and has length"); + is([], L(), "defined and has length"); + + like( + intercept { + is(undef, L()); + is('', L()); + }, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + }, + "got fail for L" + ); +}; + +subtest exact_ref => sub { + my $ref = {}; + + my $check = exact_ref($ref); my $line = __LINE__; + is($check->lines, [$line], "correct line"); + + my $hash = {}; + my $events = intercept { + is($ref, $check, "pass"); + is($hash, $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [["$hash", '==', "$ref", $line]], + ); + + end; + }, + "Got events" + ); +}; + +subtest string => sub { + my $check = string "foo"; my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $events = intercept { + is('foo', $check, "pass"); + is('bar', $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/bar eq foo/, $line]], + ); + end; + }, + "Got events" + ); + + my ($check1, $check2) = (string("foo", negate => 1), !string("foo")); + $line = __LINE__ - 1; + + for $check ($check1, $check2) { + is($check->lines, [$line], "Got line number"); + + $events = intercept { + is('bar', $check, "pass"); + is('foo', $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/foo ne foo/, $line]], + ); + end; + }, + "Got events" + ); + } +}; + +subtest number => sub { + my $check = number "22.0"; my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $events = intercept { + is(22, $check, "pass"); + is("22.0", $check, "pass"); + is(12, $check, "fail"); + is('xxx', $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/12 == 22.0/, $line]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/xxx == 22.0/, $line]], + ); + end; + }, + "Got events" + ); + + my ($check1, $check2) = (number("22.0", negate => 1), !number("22.0")); + $line = __LINE__ - 1; + + for $check ($check1, $check2) { + is($check->lines, [$line], "Got line number"); + + $events = intercept { + is(12, $check, "pass"); + is(22, $check, "fail"); + is("22.0", $check, "fail"); + is('xxx', $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/22 != 22.0/, $line]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/22.0 != 22.0/, $line]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/xxx != 22.0/, $line]], + ); + + end; + }, + "Got events" + ); + } + + $line = __LINE__+1; + my @tests = ( + {check => number_lt(25), failval => 30, op => '<', failop => '>=', checkval => 25}, + {check => number_le(25), failval => 30, op => '<=', failop => '>', checkval => 25}, + {check => number_ge(15), failval => 10, op => '>=', failop => '<', checkval => 15}, + {check => number_gt(15), failval => 10, op => '>', failop => '<=', checkval => 15}, + ); + + for my $test (@tests) { + my $check= $test->{check}; + + is($check->lines, [$line], "Got line number"); + + $events = intercept { + is(20, $check, "pass"); + is($test->{failval}, $check, "fail"); + is(20, !$check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[@{$test}{qw/ failval op checkval /}, $line]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[20, @{$test}{qw/ failop checkval /}, $line]], + ); + + end; + }, + "Got events" + ); + } +}; + +subtest float => sub { + subtest float_number => sub { + # float should pass all of the number subtests + my $check = float("22.0"); my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $events = intercept { + is(22, $check, "pass"); + is("22.0", $check, "pass"); + is(12, $check, "fail"); + is('xxx', $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [['12', '==', $check->name, $line]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [['xxx', '==', $check->name, $line]], + ); + + end; + }, + "Got events" + ); + + my ($check1, $check2) = (float("22.0", negate => 1), !float("22.0")); + $line = __LINE__ - 1; + + for $check ($check1, $check2) { + is($check->lines, [$line], "Got line number"); + + $events = intercept { + is(12, $check, "pass"); + is(22, $check, "fail"); + is("22.0", $check, "fail"); + is('xxx', $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [['22', '!=', $check->name, $line]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [['22.0', '!=', $check->name, $line]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [['xxx', '!=', $check->name, $line]], + ); + + end; + }, + "Got float events" + ); + } + }; + subtest float_rounding => sub { + my $check = float("22.0"); + my $check_3 = float("22.0", tolerance => .001); + + is($check->tolerance, 1e-08, "default tolerance"); + is($check_3->tolerance, 0.001, "custom tolerance"); + + my $check_p3 = float("22.0", precision => 3); + is($check_p3->precision, 3, "custom precision"); + is($check_p3->name, "22.000", "custom precision name"); + }; + subtest rounded_and_within => sub { + my $check = within("22.0"); + my $check_3 = within("22.0", .001); + + is($check->tolerance, 1e-08, "default tolerance"); + is($check_3->tolerance, 0.001, "custom tolerance"); + + my $check_p3 = rounded("22.0", 3); + is($check_p3->precision, 3, "custom precision"); + is($check_p3->name, "22.000", "custom precision name"); + }; +}; + + +subtest bool => sub { + my @true = (1, 'yup', '0 but true', ' ', {}); + my @false = (0, '0', '', undef); + + for my $true (@true) { + for my $true2 (@true) { + is($true2, bool($true), "Both true"); + + my $line = __LINE__ + 2; + is( + intercept { is($true2, !bool($true)) }, + array { + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [["", '!=', "", $line]], + ); + end; + }, + "true($true2) + true($true) + negate" + ); + } + + for my $false (@false) { + is($false, !bool($true), "true + false + !"); + is($false, bool($true, negate => 1), "true + false + negate"); + + my $render = ''; + + my $line = __LINE__ + 2; + is( + intercept { is($false, bool($true)) }, + array { + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[$render, '==', "", $line]], + ); + end; + }, + "$render + TRUE ($true) + negate" + ); + } + } + + for my $false (@false) { + my $render1 = ''; + for my $false2 (@false) { + is($false2, bool($false), "false + false"); + + my $render2 = ''; + + my $line = __LINE__ + 2; + is( + intercept { is($false2, !bool($false)) }, + array { + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[$render2, '!=', $render1, $line]], + ); + end; + }, + "$render2 + $render1 + negate" + ); + } + + for my $true (@true) { + is($true, !bool($false), "true + false + !"); + is($true, bool($false, negate => 1), "true + false + negate"); + + my $line = __LINE__ + 2; + is( + intercept { is($true, bool($false)) }, + array { + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [["", '==', $render1, $line]], + ); + end; + }, + "TRUE ($true) + $render1 + negate" + ); + } + } + + my $arr = []; + my $line = __LINE__ + 2; + is( + intercept { is($arr, [bool(0)]) }, + array { + fail_table( + header => [qw/PATH GOT OP CHECK LNs/], + rows => [['[0]', "", '==', '', $line],], + ); + end; + }, + "Value must exist" + ); +}; + +{ + package Foo; + + package Foo::Bar; + our @ISA = 'Foo'; + + package Baz; +} + +subtest check_isa => sub { + my $check = check_isa "Foo"; my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $foo_bar = bless {}, 'Foo::Bar'; + my $baz = bless {}, 'Baz'; + + my $events = intercept { + is($foo_bar, $check, "pass"); + is($baz, $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [["$baz", qw/isa Foo/, $line]], + ); + end; + }, + "Got events" + ); + + my ($check1, $check2) = (check_isa("Foo", negate => 1), !check_isa("Foo")); + $line = __LINE__ - 1; + + for $check ($check1, $check2) { + is($check->lines, [$line], "Got line number"); + + $events = intercept { + is($baz, $check, "pass"); + is($foo_bar, $check, "fail"); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [["$foo_bar", qw/!isa Foo/, $line]], + ); + end; + }, + "Got events" + ); + } +}; + + +subtest match => sub { + my $check = match qr/xyz/; my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $events = intercept { + is('axyzb', $check, "pass"); + is('abcde', $check, "fail"); + }; + + my $rx = "" . qr/xyz/; + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/abcde =~/, "$rx", $line]], + ); + + end; + }, + "Got events" + ); +}; + +subtest '!match' => sub { + my $check = !match qr/xyz/; my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $events = intercept { + is('abcde', $check, "pass"); + is('axyzb', $check, "fail"); + }; + + my $rx = "" . qr/xyz/; + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/axyzb !~/, "$rx", $line]], + ); + + end; + }, + "Got events" + ); +}; + +subtest '!mismatch' => sub { + my $check = !mismatch qr/xyz/; my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $events = intercept { + is('axyzb', $check, "pass"); + is('abcde', $check, "fail"); + }; + + my $rx = "" . qr/xyz/; + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/abcde =~/, "$rx", $line]], + ); + + end; + }, + "Got events" + ); +}; + +subtest mismatch => sub { + my $check = mismatch qr/xyz/; my $line = __LINE__; + is($check->lines, [$line], "Got line number"); + + my $events = intercept { + is('abcde', $check, "pass"); + is('axyzb', $check, "fail"); + }; + + my $rx = "" . qr/xyz/; + like( + $events, + array { + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[qw/axyzb !~/, "$rx", $line]], + ); + + end; + }, + "Got events" + ); +}; + +subtest check => sub { + my @lines; + my $one = validator sub { $_ ? 1 : 0 }; push @lines => __LINE__; + my $two = validator two => sub { $_ ? 1 : 0 }; push @lines => __LINE__; + my $thr = validator 't', thr => sub { $_ ? 1 : 0 }; push @lines => __LINE__; + + is($one->lines, [$lines[0]], "line 1"); + is($two->lines, [$lines[1]], "line 2"); + is($thr->lines, [$lines[2]], "line 3"); + + my $events = intercept { + is(1, $one, 'pass'); + is(1, $two, 'pass'); + is(1, $thr, 'pass'); + + is(0, $one, 'fail'); + is(0, $two, 'fail'); + is(0, $thr, 'fail'); + }; + + like( + $events, + array { + event Ok => {pass => 1}; + event Ok => {pass => 1}; + event Ok => {pass => 1}; + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[0, 'CODE(...)', '', $lines[0]]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[0, 'CODE(...)', 'two', $lines[1]]], + ); + + fail_table( + header => [qw/GOT OP CHECK LNs/], + rows => [[0, 't', 'thr', $lines[2]]], + ); + + end; + }, + "Got events" + ); +}; + +subtest prop => sub { + like( + dies { prop x => 1 }, + qr/No current build/, + "Need a build" + ); + + like( + dies { [meta { my $x = prop x => 1 }] }, + qr/'prop' should only ever be called in void context/, + "restricted context" + ); + + is( + [1], + array { prop size => 1; etc; }, + "Array builder supports 'prop'" + ); + + is( + [1], + bag { prop size => 1; etc; }, + "Bag builder supports 'prop'" + ); + + is( + { foo => 1, }, + hash { prop size => 1; etc; }, + "Hash builder supports 'prop'" + ); + + my $events = intercept { + is( [1], array { prop size => 2; etc; } ); + is( [1], bag { prop size => 2; etc; } ); + is( { foo => 1, }, hash { prop size => 2; etc; } ); + }; + + is( + $events, + array { + filter_items { grep { ref =~ /::Ok/ } @_ }; + all_items object { call pass => F }; + etc; + } + ); +}; + +subtest end => sub { + like( + dies { end() }, + qr/No current build/, + "Need a build" + ); + + like( + dies { [meta { end() }] }, + qr/'Test2::Compare::Meta.*' does not support 'ending'/, + "Build does not support end" + ); + + like( + dies { [array { [end()] }] }, + qr/'end' should only ever be called in void context/, + "end context" + ); +}; + +subtest field => sub { + like( + dies { field a => 1 }, + qr/No current build/, + "Need a build" + ); + + like( + dies { [array { field a => 1 }] }, + qr/'Test2::Compare::Array.*' does not support hash field checks/, + "Build does not take fields" + ); + + like( + dies { [hash { [field a => 1] }] }, + qr/'field' should only ever be called in void context/, + "field context" + ); +}; + +subtest filter_items => sub { + like( + dies { filter_items {1} }, + qr/No current build/, + "Need a build" + ); + + like( + dies { [hash { filter_items {1} }] }, + qr/'Test2::Compare::Hash.*' does not support filters/, + "Build does not take filters" + ); + + like( + dies { [array { [filter_items {1}] }] }, + qr/'filter_items' should only ever be called in void context/, + "filter context" + ); +}; + +subtest item => sub { + like( + dies { item 0 => 'a' }, + qr/No current build/, + "Need a build" + ); + + like( + dies { [hash { item 0 => 'a' }] }, + qr/'Test2::Compare::Hash.*' does not support array item checks/, + "Build does not take items" + ); + + like( + dies { [array { [ item 0 => 'a' ] }] }, + qr/'item' should only ever be called in void context/, + "item context" + ); +}; + +subtest call => sub { + like( + dies { call foo => 1 }, + qr/No current build/, + "Need a build" + ); + + like( + dies { [hash { call foo => 1 }] }, + qr/'Test2::Compare::Hash.*' does not support method calls/, + "Build does not take methods" + ); + + like( + dies { [object { [ call foo => 1 ] }] }, + qr/'call' should only ever be called in void context/, + "call context" + ); +}; + +subtest check => sub { + like( + dies { check 'a' }, + qr/No current build/, + "Need a build" + ); + + like( + dies { [hash { check 'a' }] }, + qr/'Test2::Compare::Hash.*' is not a check-set/, + "Build must support checks" + ); + + like( + dies { [in_set(sub { [ check 'a' ] })] }, + qr/'check' should only ever be called in void context/, + "check context" + ); +}; + +subtest meta => sub { + my $x = bless {}, 'Foo'; + my $check = meta { + prop blessed => 'Foo'; + prop reftype => 'HASH'; + prop this => $x; + }; + my @lines = map { __LINE__ - $_ } reverse 1 .. 5; + + is($x, $check, "meta pass"); + + my $array = []; + my $events = intercept { is($array, $check, "meta fail") }; + like( + $events, + array { + fail_table( + header => [qw/PATH GOT OP CHECK LNs/], + rows => [ + ["", "$array", '', '', "$lines[0], $lines[4]"], + ['', '', '', 'Foo', $lines[1]], + ['', 'ARRAY', 'eq', 'HASH', $lines[2]], + ['', "$array", '', '', $lines[3]], + ], + ); + }, + "got failure" + ); +}; + +subtest hash => sub { + my $empty = hash { etc }; + + my $full = hash { + field a => 1; + field b => 2; + etc; + }; + + my $closed = hash { + field a => 1; + field b => 2; + end(); + }; + + isa_ok($_, 'Test2::Compare::Base', 'Test2::Compare::Hash') for $empty, $full, $closed; + + is({}, $empty, "empty hash"); + is({a => 1}, $empty, "unclosed empty matches anything"); + + is({a => 1, b => 2}, $full, "full exact match"); + is({a => 1, b => 2, c => 3 }, $full, "full with extra"); + + is({a => 1, b => 2}, $closed, "closed"); + + my $events = intercept { + is([], $empty); + is(undef, $empty); + is(1, $empty); + is('HASH', $empty); + + is({}, $full); + is({a => 2, b => 2}, $full); + + is({a => 1, b => 2, c => 3}, $closed); + }; + + @$events = grep {$_->isa('Test2::Event::Fail')} @$events; + + is(@$events, 7, '7 fail events'); +}; + +subtest array => sub { + my $empty = array { etc }; + + my $simple = array { + item 'a'; + item 'b'; + item 'c'; + etc; + }; + + my $filtered = array { + filter_items { grep { m/a/ } @_ }; + item 0 => 'a'; + item 1 => 'a'; + item 2 => 'a'; + etc; + }; + + my $shotgun = array { + item 1 => 'b'; + item 3 => 'd'; + etc; + }; + + my $closed = array { + item 0 => 'a'; + item 1 => 'b'; + item 2 => 'c'; + end; + }; + + is([], $empty, "empty array"); + is(['a'], $empty, "any array matches empty"); + + is([qw/a b c/], $simple, "simple exact match"); + is([qw/a b c d e/], $simple, "simple with extra"); + + is([qw/x a b c a v a t t/], $filtered, "filtered out unwanted values"); + + is([qw/a b c d e/], $shotgun, "selected indexes only"); + + is([qw/a b c/], $closed, "closed array"); + + my $events = intercept { + is({}, $empty); + is(undef, $empty); + is(1, $empty); + is('ARRAY', $empty); + + is([qw/x y z/], $simple); + is([qw/a b x/], $simple); + is([qw/x b c/], $simple); + + is([qw/aa a a a b/], $filtered); + + is([qw/b c d e f/], $shotgun); + + is([qw/a b c d/], $closed); + }; + + @$events = grep {$_->isa('Test2::Event::Fail')} @$events; + is(@$events, 10, "10 fail events"); +}; + +subtest bag => sub { + my $empty = bag { etc }; + + my $simple = bag { + item 'a'; + item 'b'; + item 'c'; + etc; + }; + + my $closed = array { + item 0 => 'a'; + item 1 => 'b'; + item 2 => 'c'; + end; + }; + + is([], $empty, "empty array"); + is(['a'], $empty, "any array matches empty"); + + is([qw/a b c/], $simple, "simple exact match"); + is([qw/b c a/], $simple, "simple out of order"); + is([qw/a b c d e/], $simple, "simple with extra"); + is([qw/b a d e c/], $simple, "simple with extra, out of order"); + + is([qw/a b c/], $closed, "closed array"); + + my $events = intercept { + is({}, $empty); + is(undef, $empty); + is(1, $empty); + is('ARRAY', $empty); + + is([qw/x y z/], $simple); + is([qw/a b x/], $simple); + is([qw/x b c/], $simple); + + is([qw/a b c d/], $closed); + }; + + @$events = grep {$_->isa('Test2::Event::Fail')} @$events; + is(@$events, 8, "8 fail events"); +}; + +subtest object => sub { + my $empty = object { }; + + my $simple = object { + call foo => 'foo'; + call bar => 'bar'; + call_list many => [1,2,3,4]; + call_hash many => {1=>2,3=>4}; + call [args => qw(a b)] => {a=>'b'}; + }; + + my $array = object { + call foo => 'foo'; + call bar => 'bar'; + call_list many => [1,2,3,4]; + call_hash many => {1=>2,3=>4}; + call [args => qw(a b)] => {a=>'b'}; + item 0 => 'x'; + item 1 => 'y'; + etc; + }; + + my $closed_array = object { + call foo => 'foo'; + call bar => 'bar'; + call_list many => [1,2,3,4]; + call_hash many => {1=>2,3=>4}; + call [args => qw(a b)] => {a=>'b'}; + item 0 => 'x'; + item 1 => 'y'; + end(); + }; + + my $hash = object { + call foo => 'foo'; + call bar => 'bar'; + call_list many => [1,2,3,4]; + call_hash many => {1=>2,3=>4}; + call [args => qw(a b)] => {a=>'b'}; + field x => 1; + field y => 2; + etc; + }; + + my $closed_hash = object { + call foo => 'foo'; + call bar => 'bar'; + call_list many => [1,2,3,4]; + call_hash many => {1=>2,3=>4}; + call [args => qw(a b)] => {a=>'b'}; + field x => 1; + field y => 2; + end(); + }; + + my $meta = object { + call foo => 'foo'; + call bar => 'bar'; + call_list many => [1,2,3,4]; + call_hash many => {1=>2,3=>4}; + call [args => qw(a b)] => {a=>'b'}; + prop blessed => 'ObjectFoo'; + prop reftype => 'HASH'; + prop isa => 'ObjectFoo'; + etc; + }; + + my $mix = object { + call foo => 'foo'; + call bar => 'bar'; + call_list many => [1,2,3,4]; + call_hash many => {1=>2,3=>4}; + call [args => qw(a b)] => {a=>'b'}; + field x => 1; + field y => 2; + prop blessed => 'ObjectFoo'; + prop reftype => 'HASH'; + etc; + }; + + my $obf = mock 'ObjectFoo' => (add => [ + foo => sub { 'foo' }, + bar => sub { 'bar' }, + baz => sub {'baz'}, + many => sub { (1,2,3,4) }, + args => sub { shift; +{@_} }, + ]); + my $obb = mock 'ObjectBar' => (add => [ + foo => sub { 'nop' }, + baz => sub { 'baz' }, + many => sub { (1,2,3,4) }, + args => sub { shift; +{@_} }, + ]); + + is(bless({}, 'ObjectFoo'), $empty, "Empty matches any object"); + is(bless({}, 'ObjectBar'), $empty, "Empty matches any object"); + + is(bless({}, 'ObjectFoo'), $simple, "simple match hash"); + is(bless([], 'ObjectFoo'), $simple, "simple match array"); + + is(bless([qw/x y/], 'ObjectFoo'), $array, "array match"); + is(bless([qw/x y z/], 'ObjectFoo'), $array, "array match"); + + is(bless([qw/x y/], 'ObjectFoo'), $closed_array, "closed array"); + + is(bless({x => 1, y => 2}, 'ObjectFoo'), $hash, "hash match"); + is(bless({x => 1, y => 2, z => 3}, 'ObjectFoo'), $hash, "hash match"); + + is(bless({x => 1, y => 2}, 'ObjectFoo'), $closed_hash, "closed hash"); + + is(bless({}, 'ObjectFoo'), $meta, "meta match"); + + is(bless({x => 1, y => 2, z => 3}, 'ObjectFoo'), $mix, "mix"); + + my $events = intercept { + is({}, $empty); + is(undef, $empty); + is(1, $empty); + is('ARRAY', $empty); + + is(bless({}, 'ObjectBar'), $simple, "simple match hash"); + is(bless([], 'ObjectBar'), $simple, "simple match array"); + + is(bless([qw/a y/], 'ObjectFoo'), $array, "array match"); + is(bless([qw/a y z/], 'ObjectFoo'), $array, "array match"); + + is(bless([qw/x y z/], 'ObjectFoo'), $closed_array, "closed array"); + + is(bless({x => 2, y => 2}, 'ObjectFoo'), $hash, "hash match"); + is(bless({x => 2, y => 2, z => 3}, 'ObjectFoo'), $hash, "hash match"); + + is(bless({x => 1, y => 2, z => 3}, 'ObjectFoo'), $closed_hash, "closed hash"); + + is(bless({}, 'ObjectBar'), $meta, "meta match"); + is(bless([], 'ObjectFoo'), $meta, "meta match"); + + is(bless({}, 'ObjectFoo'), $mix, "mix"); + is(bless([], 'ObjectFoo'), $mix, "mix"); + is(bless({x => 1, y => 2, z => 3}, 'ObjectBar'), $mix, "mix"); + }; + + @$events = grep {$_->isa('Test2::Event::Fail')} @$events; + is(@$events, 17, "17 fail events"); + +}; + +subtest event => sub { + like( + dies { event 0 => {} }, + qr/type is required/, + "Must specify event type" + ); + + my $one = event Ok => {}; + is($one->meta->items->[0]->[1], 'Test2::Event::Ok', "Event type check"); + + $one = event '+Foo::Event::Diag' => {}; + is($one->meta->items->[0]->[1], 'Foo::Event::Diag', "Event type check with +"); + + my $empty = event 'Ok'; + isa_ok($empty, 'Test2::Compare::Event'); + + like( + dies { event Ok => 'xxx' }, + qr/'xxx' is not a valid event specification/, + "Invalid spec" + ); + + my $from_sub = event Ok => sub { + call pass => 1; + field name => 'pass'; + etc; + }; + + my $from_hash = event Ok => sub { field pass => 1; field name => 'pass'; etc}; + + my $from_build = array { event Ok => sub { field pass => 1; field name => 'pass'; etc } }; + + my $pass = intercept { ok(1, 'pass') }; + my $fail = intercept { ok(0, 'fail') }; + my $diag = intercept { diag("hi") }; + + is($pass->[0], $empty, "empty matches any event of the type"); + is($fail->[0], $empty, "empty on a failed event"); + is($pass->[0], $from_sub, "builder worked"); + is($pass->[0], $from_hash, "hash spec worked"); + is($pass, $from_build, "worked in build"); + + my $events = intercept { + is($diag->[0], $empty); + + is($fail->[0], $from_sub, "builder worked"); + is($fail->[0], $from_hash, "hash spec worked"); + is($fail, $from_build, "worked in build"); + }; + + @$events = grep {$_->isa('Test2::Event::Fail')} @$events; + is(@$events, 4, "4 fail events"); + + like( + dies { event Ok => {}; 1 }, + qr/No current build!/, + "Need a build!" + ); +}; + +subtest sets => sub { + subtest check_set => sub { + is( + 'foo', + check_set(sub { check 'foo'; check match qr/fo/; check match qr/oo/ }), + "matches everything in set" + ); + + is( + 'foo', + check_set('foo', match qr/fo/, match qr/oo/), + "matches everything in set" + ); + + like( + intercept { + is('fox', check_set(sub{ check match qr/fo/; check 'foo' })); + is('fox', check_set(match qr/fo/, 'foo')); + }, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + end; + }, + "Failed cause not all checks passed" + ); + }; + + subtest in_set => sub { + is( + 'foo', + in_set(sub { check 'x'; check 'y'; check 'foo' }), + "Item is in set" + ); + is( + 'foo', + in_set(qw/x y foo/), + "Item is in set" + ); + + like( + intercept { + is('fox', in_set(sub{ check 'x'; check 'foo' })); + is('fox', in_set('x', 'foo')); + }, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + end; + }, + "Failed cause not all checks passed" + ); + }; + + subtest not_in_set => sub { + is( + 'foo', + not_in_set(sub { check 'x'; check 'y'; check 'z' }), + "Item is not in set" + ); + is( + 'foo', + not_in_set(qw/x y z/), + "Item is not in set" + ); + + like( + intercept { + is('fox', not_in_set(sub{ check 'x'; check 'fox' })); + is('fox', not_in_set('x', 'fox')); + }, + array { + filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; + event Fail => {}; + event Fail => {}; + end; + }, + "Failed cause not all checks passed" + ); + + }; +}; + +subtest regex => sub { + is(qr/abc/, qr/abc/, "same regex"); + + my $events = intercept { + is(qr/abc/i, qr/abc/, "Wrong flags"); + is(qr/abc/, qr/abcd/, "wrong pattern"); + is(qr/abc/, exact_ref(qr/abc/), "not an exact match"); + }; + + @$events = grep {$_->isa('Test2::Event::Fail')} @$events; + is(@$events, 3, "3 fail events"); +}; + +subtest isnt => sub { + isnt('a', 'b', "a is not b"); + isnt({}, [], "has is not array"); + isnt(0, 1, "0 is not 1"); + + my $events = intercept { + isnt([], []); + isnt('a', 'a'); + isnt(1, 1); + isnt({}, {}); + }; + + @$events = grep {$_->isa('Test2::Event::Ok')} @$events; + is(@$events, 4, "4 events"); + ok(!$_->{pass}, "Event was a failure") for @$events +}; + +subtest unlike => sub { + unlike('a', 'b', "a is not b"); + unlike({}, [], "has is not array"); + unlike(0, 1, "0 is not 1"); + unlike('aaa', qr/bbb/, "aaa does not match /bbb/"); + + my $events = intercept { + unlike([], []); + unlike('a', 'a'); + unlike(1, 1); + unlike({}, {}); + unlike( 'foo', qr/o/ ); + }; + + @$events = grep {$_->isa('Test2::Event::Ok')} @$events; + is(@$events, 5, "5 events"); + ok(!$_->{pass}, "Event was a failure") for @$events +}; + +subtest all_items_on_array => sub { + like( + [qw/a aa aaa/], + array { + all_items match qr/^a+$/; + item 'a'; + item 'aa'; + }, + "All items match regex" + ); + + my @lines; + my $array = [qw/a aa aaa/]; + my $regx = qr/^b+$/; + my $events = intercept { + is( + $array, + array { + all_items match $regx; push @lines => __LINE__; + item 'b'; push @lines => __LINE__; + item 'aa'; push @lines => __LINE__; + end; + }, + "items do not all match, and diag reflects all issues, and in order" + ); + }; + like( + $events, + array { + fail_table( + header => [qw/PATH GOT OP CHECK LNs/], + rows => [ + ['', "$array", '', "", ($lines[0] - 1) . ", " . ($lines[-1] + 2)], + ['[0]', 'a', '=~', "$regx", $lines[0]], + ['[0]', 'a', 'eq', 'b', $lines[1]], + ['[1]', 'aa', '=~', "$regx", $lines[0]], + ['[2]', 'aaa', '=~', "$regx", $lines[0]], + ['[2]', 'aaa', '!exists', '', ''], + ], + ); + }, + "items do not all match, and diag reflects all issues, and in order" + ); +}; + +subtest all_items_on_bag => sub { + like( + [qw/a aa aaa/], + bag { + all_items match qr/^a+$/; + item 'a'; + item 'aa'; + }, + "All items match regex" + ); + + my @lines; + my $array = [qw/a aa aaa/]; + my $regx = qr/^b+$/; + my $events = intercept { + is( + $array, + bag { + all_items match $regx; push @lines => __LINE__; + item 'b'; push @lines => __LINE__; + item 'aa'; push @lines => __LINE__; + end; + }, + "items do not all match, and diag reflects all issues, and in order" + ); + }; + + like( + $events, + array { + fail_table( + header => [qw/PATH GOT OP CHECK LNs/], + rows => [ + ['', "$array", '', "", ($lines[0] - 1) . ", " . ($lines[-1] + 2)], + ['[*]', '', '', 'b', $lines[1]], + ['[0]', 'a', '=~', "$regx", $lines[0]], + ['[1]', 'aa', '=~', "$regx", $lines[0]], + ['[2]', 'aaa', '=~', "$regx", $lines[0]], + ], + ); + }, + "items do not all match, and diag reflects all issues, and in order" + ); +}; + +subtest all_keys_and_vals => sub { + is( + {a => 'a', 'aa' => 'aa', 'aaa' => 'aaa'}, + hash { + all_values match qr/^a+$/; + all_keys match qr/^a+$/; + field a => 'a'; + field aa => 'aa'; + field aaa => 'aaa'; + }, + "All items match regex" + ); + + my @lines; + my $hash = {a => 'a', 'aa' => 'aa', 'aaa' => 'aaa'}; + my $regx = qr/^b+$/; + my $events = intercept { + is( + $hash, + hash { + all_keys match $regx; push @lines => __LINE__; + all_vals match $regx; push @lines => __LINE__; + field aa => 'aa'; push @lines => __LINE__; + field b => 'b'; push @lines => __LINE__; + end; + }, + "items do not all match, and diag reflects all issues, and in order" + ); + }; + like( + $events, + array { + fail_table( + header => [qw/PATH GOT OP CHECK LNs/], + rows => [ + ['', "$hash", '', '', join(', ', $lines[0] - 1, $lines[-1] + 2)], + ['{aa} ', 'aa', '=~', "$regx", $lines[0]], + ['{aa}', 'aa', '=~', "$regx", $lines[1]], + ['{b}', '', '', 'b', $lines[3]], + ['{a} ', 'a', '=~', "$regx", $lines[0]], + ['{a}', 'a', '=~', "$regx", $lines[1]], + ['{a}', 'a', '!exists', '', '',], + ['{aaa} ', 'aaa', '=~', "$regx", $lines[0]], + ['{aaa}', 'aaa', '=~', "$regx", $lines[1]], + ['{aaa}', 'aaa', '!exists', '', ''], + ], + ); + }, + "items do not all match, and diag reflects all issues, and in order" + ); +}; + +{ + package Local::MockDumper; + use Data::Dumper (); + no warnings 'once'; + our @ISA = 'Data::Dumper'; + sub Dump { + my $self = shift; + our @args = @_; + our $deparse = $Data::Dumper::Deparse; + return $self->SUPER::Dump(@_); + } +} + +subtest 'T2_AUTO_DUMP and T2_AUTO_DEPARSE' => sub { + + subtest 'Trivial example where tests pass' => sub { + local @Local::MockDumper::args = 'NOT CALLED'; + local $Local::MockDumper::deparse = 'NOT CALLED'; + my $events = intercept { + local $ENV{T2_AUTO_DUMP} = 'Local::MockDumper'; + local $ENV{T2_AUTO_DEPARSE} = 0; + is( [], [], 'ok' ); + }; + is( + $events, + array { + event Ok => sub {}; + end; + }, + 'MockDumper not called because test passed', + ); + }; + + subtest 'Trivial example where test fails but autodump is not in use' => sub { + local @Local::MockDumper::args = 'NOT CALLED'; + local $Local::MockDumper::deparse = 'NOT CALLED'; + my $events = intercept { + local $ENV{T2_AUTO_DUMP} = 0; + local $ENV{T2_AUTO_DEPARSE} = 0; + is( {}, [], 'ok' ); + }; + is( + $events, + array { + event Fail => sub {}; + end; + }, + 'MockDumper not called because autodump not enabled', + ); + is( + \@Local::MockDumper::args, + ['NOT CALLED'], + 'MockDumper did not get any arguments' + ); + is( + $Local::MockDumper::deparse, + 'NOT CALLED', + '$Deparse was not altered' + ); + }; + + subtest 'Simple example where test fails and gets autodumped' => sub { + local @Local::MockDumper::args = 'NOT CALLED'; + local $Local::MockDumper::deparse = 'NOT CALLED'; + my $events = intercept { + local $ENV{T2_AUTO_DUMP} = 'Local::MockDumper'; + local $ENV{T2_AUTO_DEPARSE} = 0; + is( {}, [], 'ok' ); + }; + is( + $events, + array { + event Fail => sub {}; + event Diag => sub { + call message => match qr/\$GOT/; + }; + end; + }, + 'MockDumper called because test failed', + ); + is( + \@Local::MockDumper::args, + [[{}], ['GOT']], + 'MockDumper was passed the correct arguments' + ); + is( + $Local::MockDumper::deparse, + F(), + '$Deparse was false' + ); + }; + + subtest 'Simple example where test fails and gets autodumped' => sub { + local @Local::MockDumper::args = 'NOT CALLED'; + local $Local::MockDumper::deparse = 'NOT CALLED'; + my $events = intercept { + local $ENV{T2_AUTO_DUMP} = 'Local::MockDumper'; + local $ENV{T2_AUTO_DEPARSE} = 1; + is( sub { "XYZ" }, [], 'ok' ); + }; + is( + $events, + array { + event Fail => sub {}; + event Diag => sub { + call message => match qr/\$GOT/; + call message => match qr/XYZ/; + }; + end; + }, + 'MockDumper called because test failed', + ); + is( + $Local::MockDumper::deparse, + T(), + '$Deparse was true' + ); + }; +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Defer.t b/cpan/Test2-Suite/t/modules/Tools/Defer.t new file mode 100644 index 000000000000..153dfb796fe5 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Defer.t @@ -0,0 +1,186 @@ +use strict; +use warnings; +use Test2::Tools::Defer; +# HARNESS-NO-FORK + +my $file = __FILE__; + +my $START_LINE; +BEGIN { + $START_LINE = __LINE__; + def ok => (1, "truth"); + def is => (1, 1, "1 is 1"); + def is => ({}, {}, "hash is hash"); + + def ok => (0, 'lies'); + def is => (0, 1, "1 is not 0"); + def is => ({}, [], "a hash is not an array"); +} + +use Test2::Bundle::Extended -target => 'Test2::Tools::Defer'; + +sub capture(&) { + my $code = shift; + + my ($err, $out) = ("", ""); + + my ($ok, $e); + { + local *STDOUT; + local *STDERR; + + ($ok, $e) = Test2::Util::try(sub { + 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, + }; +} + +is( + intercept { do_def }, + array { + filter_items { grep { $_->isa('Test2::Event::Ok') || $_->isa('Test2::Event::Fail') } @_ }; + + event Ok => sub { + call pass => 1; + call name => 'truth'; + prop file => "(eval in Test2::Tools::Defer) " . __FILE__; + prop line => $START_LINE + 1; + prop package => __PACKAGE__; + }; + + event Ok => sub { + call pass => 1; + call name => '1 is 1'; + prop file => "(eval in Test2::Tools::Defer) " . __FILE__; + prop line => $START_LINE + 2; + prop package => __PACKAGE__; + }; + + event Ok => sub { + call pass => 1; + call name => 'hash is hash'; + prop file => "(eval in Test2::Tools::Defer) " . __FILE__; + prop line => $START_LINE + 3; + prop package => __PACKAGE__; + }; + + event Ok => sub { + call pass => 0; + call name => 'lies'; + prop file => "(eval in Test2::Tools::Defer) " . __FILE__; + prop line => $START_LINE + 5; + prop package => __PACKAGE__; + }; + + event Fail => sub { + call name => '1 is not 0'; + prop file => "(eval in Test2::Tools::Defer) " . __FILE__; + prop line => $START_LINE + 6; + prop package => __PACKAGE__; + }; + + event Fail => sub { + call name => 'a hash is not an array'; + prop file => "(eval in Test2::Tools::Defer) " . __FILE__; + prop line => $START_LINE + 7; + prop package => __PACKAGE__; + }; + + end; + }, + "got expected events" +); + +def ok => (1, "truth"); +def is => (1, 1, "1 is 1"); +def is => ({}, {}, "hash is hash"); + +# Actually run some that pass +do_def(); + +like( + dies { do_def() }, + qr/No tests to run/, + "Fails if there are no tests" +); + +my $line1 = __LINE__ + 1; +sub oops { die 'oops' } + +my $line2 = __LINE__ + 1; +def oops => (1); +like( dies { do_def() }, < (1, "pass"); + } + def ok => (1, "pass"); + + my $new_exit = 0; + my $out = capture { Test2::Tools::Defer::_verify(undef, 0, \$new_exit) }; + + is($new_exit, 255, "exit set to 255 due to unrun tests"); + like( + $out->{STDOUT}, + qr/not ok - deferred tests were not run/, + "Got failed STDOUT line" + ); + + like( + $out->{STDERR}, + qr/# 'main' has deferred tests that were never run/, + "We see that main failed" + ); + + like( + $out->{STDERR}, + qr/# 'Foo' has deferred tests that were never run/, + "We see that Foo failed" + ); +} + +{ + local $? = 101; + def ok => (1, "pass"); + my $out = capture { Test2::Tools::Defer::_verify() }; + is($?, 101, "did not change exit code"); + like( + $out->{STDOUT}, + qr/not ok - deferred tests were not run/, + "Got failed STDOUT line" + ); + + like( + $out->{STDERR}, + qr/# 'main' has deferred tests that were never run/, + "We see that main failed" + ); +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Encoding.t b/cpan/Test2-Suite/t/modules/Tools/Encoding.t new file mode 100644 index 000000000000..74340b63eee6 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Encoding.t @@ -0,0 +1,54 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Encoding'; + +require Test2::Formatter::TAP; + +use File::Temp qw/tempfile/; + +{ + package Temp; + use Test2::Tools::Encoding; + + main::imported_ok(qw/set_encoding/); +} + +my $warnings; +intercept { + $warnings = warns { + use utf8; + + my ($fh, $name); + my $ct = 100; + until ($fh) { + --$ct or die "Failed to get temp file after 100 tries"; + ($fh, $name) = eval { tempfile() }; + } + + Test2::API::test2_stack->top->format( + Test2::Formatter::TAP->new( + handles => [$fh, $fh, $fh], + ), + ); + + set_encoding('utf8'); + ok(1, '†'); + + unlink($name) or print STDERR "Could not remove temp file $name: $!\n"; + }; +}; + +ok(!$warnings, "set_encoding worked"); + +my $exception; +intercept { + $exception = dies { + set_encoding('utf8'); + }; +}; + +like( + $exception, + qr/Unable to set encoding on formatter ''/, + "Cannot set encoding without a formatter" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Event.t b/cpan/Test2-Suite/t/modules/Tools/Event.t new file mode 100644 index 000000000000..2431d032928f --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Event.t @@ -0,0 +1,13 @@ +use Test2::Bundle::Extended; + +imported_ok('gen_event'); + +my $e = gen_event Ok => (pass => 1, name => 'foo'); +my $c = event Ok => {pass => 1, name => 'foo', trace => {frame => [__PACKAGE__, __FILE__, __LINE__ - 1]}}; +like($e, $c, "Generated event"); + +$e = gen_event '+Test2::Event::Ok' => (pass => 1, name => 'foo'); +$c = event Ok => {pass => 1, name => 'foo', trace => {frame => [__PACKAGE__, __FILE__, __LINE__ - 1]}}; +like($e, $c, "Generated event long-form"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Exception.t b/cpan/Test2-Suite/t/modules/Tools/Exception.t new file mode 100644 index 000000000000..805549d9ca9c --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Exception.t @@ -0,0 +1,57 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Exception'; + +{ + package Foo; + use Test2::Tools::Exception qw/dies lives try_ok/; + ::imported_ok(qw/dies lives try_ok/); +} + +use Test2::API qw/intercept/; + +like( + dies { die 'xyz' }, + qr/xyz/, + "Got exception" +); + +is(dies { 0 }, undef, "no exception"); + +{ + local $@ = 'foo'; + ok(lives { 0 }, "it lives!"); + is($@, "foo", "did not change \$@"); +} + +ok(!lives { die 'xxx' }, "it died"); +like($@, qr/xxx/, "Exception is available"); + +try_ok { 0 } "No Exception from try_ok"; + +my $err; +is( + intercept { try_ok { die 'abc' } "foo"; $err = $@; }, + array { + fail_events Ok => sub { + call name => "foo"; + call pass => 0; + }; + event Diag => sub { msg => match qr/abc/; }; + }, + "Got failure + diag from try_ok" +); + +like($err, qr/abc/, '$@ has the exception'); + +like( + warning { dies { 1 } }, + qr/Useless use of dies\(\) in void context/, + "warns in void context" +); + +like( + warning { lives { 1 } }, + qr/Useless use of lives\(\) in void context/, + "warns in void context" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Exports.t b/cpan/Test2-Suite/t/modules/Tools/Exports.t new file mode 100644 index 000000000000..8464f82a924e --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Exports.t @@ -0,0 +1,31 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Exports'; + +{ + package Temp; + use Test2::Tools::Exports; + + imported_ok(qw/imported_ok not_imported_ok/); + not_imported_ok(qw/xyz/); +} + +like( + intercept { imported_ok('x') }, + array { + fail_events Ok => { pass => 0 }; + event Diag => { message => "'x' was not imported." }; + end; + }, + "Failed, x is not imported" +); + +like( + intercept { not_imported_ok('ok') }, + array { + fail_events Ok => { pass => 0 }; + event Diag => { message => "'ok' was imported." }; + end; + }, + "Failed, 'ok' is imported" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/GenTemp.t b/cpan/Test2-Suite/t/modules/Tools/GenTemp.t new file mode 100644 index 000000000000..9d7fb93d2653 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/GenTemp.t @@ -0,0 +1,44 @@ +use Test2::V0 -target => 'Test2::Tools::GenTemp'; + +use ok $CLASS => 'gen_temp'; + +use File::Spec; + +use IO::Handle; + +imported_ok qw/gen_temp/; + +my $tmp = gen_temp( + -tempdir => [CLEANUP => 1, TMPDIR => 1], + foo => "foo\n", + bar => "bar\n", + subdir => { + baz => "baz\n", + nested => { + bat => "bat", + }, + }, +); + +ok($tmp, "Got a temp dir ($tmp)"); + +ok(-d File::Spec->canonpath($_), "Created dir $_") for ( + $tmp, + "$tmp/subdir", + "$tmp/subdir/nested", +); + +for my $file (qw{foo bar subdir/baz subdir/nested/bat}) { + my $cp = File::Spec->canonpath("$tmp/$file"); + ok(-f $cp, "Created file $file"); + open(my $fh, '<', $cp) or die "Could not open file '$cp': $!"; + my $content = $file; + $content =~ s{^.*/}{}g; + $content .= "\n" unless $content eq 'bat'; + my $printable = $content; + $printable =~ s/\n/\\n/; + is(<$fh>, $content, "Got content ($printable)"); + ok($fh->eof, "$file At EOF"); +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Grab.t b/cpan/Test2-Suite/t/modules/Tools/Grab.t new file mode 100644 index 000000000000..dd8ce4ae9dc4 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Grab.t @@ -0,0 +1,35 @@ +use Test2::Bundle::Extended -target => 'Test2::Util::Grabber'; + +use Test2::Tools::Grab; + +ok(1, "initializing"); + +my $grab = grab(); +ok(1, "pass"); +my $one = $grab->events; +ok(0, "fail"); +my $events = $grab->finish; + +is(@$one, 1, "Captured 1 event"); +is(@$events, 3, "Captured 3 events"); + +like( + $one, + array { + event Ok => { pass => 1 }; + }, + "Got expected event" +); + +like( + $events, + array { + event Ok => { pass => 1 }; + event Ok => { pass => 0 }; + event Diag => { }; + end; + }, + "Got expected events" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Mock.t b/cpan/Test2-Suite/t/modules/Tools/Mock.t new file mode 100644 index 000000000000..3aa5b40bd1a8 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Mock.t @@ -0,0 +1,284 @@ +use Test2::Bundle::Extended -target => 'Test2::Compare::Custom'; + +use Test2::Tools::Mock qw{ + mock_obj mock_class + mock_do mock_build + mock_accessor mock_accessors + mock_getter mock_getters + mock_setter mock_setters + mock_building +}; + +use Scalar::Util qw/reftype blessed/; + +imported_ok qw{ + mock_obj mock_class + mock_do mock_build + mock_accessor mock_accessors + mock_getter mock_getters + mock_setter mock_setters + mock_building +}; + +subtest generators => sub { + # These are all thin wrappers around HashBase subs, we just test that we + # get subs, HashBase subtest that the thing we are wrapping produce the + # correct type of subs. + + my %accessors = mock_accessors qw/foo bar baz/; + is([sort keys %accessors], [sort qw/foo bar baz/], "All 3 keys set"); + is(reftype($accessors{$_}), 'CODE', "sub as value for $_") for qw/foo bar baz/; + + is(reftype(mock_accessor('xxx')), 'CODE', "Generated an accessor"); + + my %getters = mock_getters 'get_' => qw/foo bar baz/; + is([sort keys %getters], [sort qw/get_foo get_bar get_baz/], "All 3 keys set"); + is(reftype($getters{"get_$_"}), 'CODE', "sub as value for get_$_") for qw/foo bar baz/; + + is(reftype(mock_getter('xxx')), 'CODE', "Generated a getter"); + + my %setters = mock_setters 'set_' => qw/foo bar baz/; + is([sort keys %setters], [sort qw/set_foo set_bar set_baz/], "All 3 keys set"); + is(reftype($setters{"set_$_"}), 'CODE', "sub as value for set_$_") for qw/foo bar baz/; + + is(reftype(mock_setter('xxx')), 'CODE', "Generated a setter"); +}; + +subtest mocks => sub { + my $inst; + my $control; + my $class; + + my $object = sub { + $inst = mock_obj({}, add_constructor => [new => 'hash']); + ($control) = mocked($inst); + $class = $control->class; + }; + + my $package = sub { + $control = mock_class('Fake::Class', add_constructor => [new => 'hash']); + $class = $control->class; + $inst = $class->new; + }; + + for my $case ($object, $package) { + $case->(); + + isa_ok($control, 'Test2::Mock'); + isa_ok($inst, $class); + ok($class, "got a class"); + + subtest mocked => sub { + ok(!mocked('main'), "main class is not mocked"); + is(mocked($inst), 1, "Only 1 control object for this instance"); + my ($c) = mocked($inst); + ref_is($c, $control, "got correct control when checking if an object was mocked"); + + my $control2 = mock_class($control->class); + + is(mocked($inst), 2, "now 2 control objects for this instance"); + my ($c1, $c2) = mocked($inst); + ref_is($c1, $control, "got first control"); + ref_is($c2, $control2, "got second control"); + }; + + subtest build_and_do => sub { + like( + dies { mock_build(undef, sub { 1 }) }, + qr/mock_build requires a Test2::Mock object as its first argument/, + "control is required", + ); + + like( + dies { mock_build($control, undef) }, + qr/mock_build requires a coderef as its second argument/, + "Must have a coderef to build" + ); + + like( + dies { mock_do add => (foo => sub { 'foo' }) }, + qr/Not currently building a mock/, + "mock_do outside of a build fails" + ); + + ok(!mock_building, "no mock is building"); + my $ran = 0; + mock_build $control => sub { + is(mock_building, $control, "Building expected control"); + + like( + dies { mock_do 'foo' => 1 }, + qr/'foo' is not a valid action for mock_do\(\)/, + "invalid action" + ); + + mock_do add => ( + foo => sub { 'foo' }, + ); + + can_ok($inst, 'foo'); + is($inst->foo, 'foo', "added sub"); + + $ran++; + }; + + ok(!mock_building, "no mock is building"); + ok($ran, "build sub completed successfully"); + }; + } +}; + +subtest mock_obj => sub { + my $ref = {}; + my $obj = mock_obj $ref; + is($ref, $obj, "blessed \$ref"); + is($ref->foo(1), 1, "is vivifying object"); + + my $ran = 0; + $obj = mock_obj(sub { $ran++ }); + is($ref->foo(1), 1, "is vivifying object"); + is($ran, 1, "code ran"); + + $obj = mock_obj { foo => 'foo' } => ( + add => [ bar => sub { 'bar' }], + ); + + # We need to test the methods returned by ->can before we call the subs by + # name. This lets us be sure that this works _before_ the AUTOLOAD + # actually creates the named sub for real. + my $foo = $obj->can('foo'); + $obj->$foo('foo2'); + is($obj->$foo, 'foo2', "->can('foo') returns a method that works as a setter"); + $obj->$foo('foo'); + + my $bar = $obj->can('bar'); + is($obj->$bar, 'bar', "->can('bar') returns a method"); + ok(!$obj->can('baz'), "mock object ->can returns false for baz"); + + is($obj->foo, 'foo', "got value for foo"); + is($obj->bar, 'bar', "got value for bar"); + + ok($obj->can('foo'), "mock object ->can returns true for foo"); + ok($obj->can('bar'), "mock object ->can returns true for bar"); + ok($obj->can('isa'), "mock object ->can returns true for isa"); + + $foo = $obj->can('foo'); + + my ($c) = mocked($obj); + ok($c, "got control"); + is($obj->{'~~MOCK~CONTROL~~'}, $c, "control is stashed"); + + my $class = $c->class; + my $file = $c->file; + ok($INC{$file}, "Mocked Loaded"); + + $obj = undef; + $c = undef; + + ok(!$INC{$file}, "Not loaded anymore"); +}; + +subtest mock_class_basic => sub { + my $c = mock_class 'Fake'; + isa_ok($c, 'Test2::Mock'); + is($c->class, 'Fake', "Control for 'Fake'"); + $c = undef; + + # Check with an instance + my $i = bless {}, 'Fake'; + $c = mock_class $i; + isa_ok($c, 'Test2::Mock'); + is($c->class, 'Fake', "Control for 'Fake'"); + + is([mocked($i)], [$c], "is mocked"); +}; + +subtest post => sub { + ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; +}; + +ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; + +subtest just_mock => sub { + like( + dies { mock undef }, + qr/undef is not a valid first argument to mock/, + "Cannot mock undef" + ); + + like( + dies { mock 'fakemethodname' }, + qr/'fakemethodname' does not look like a package name, and is not a valid control method/, + "invalid mock arg" + ); + + my $c = mock 'Fake'; + isa_ok($c, 'Test2::Mock'); + is($c->class, 'Fake', "mocked correct class"); + mock $c => sub { + mock add => (foo => sub { 'foo' }); + }; + + can_ok('Fake', 'foo'); + is(Fake->foo(), 'foo', "mocked build, mocked do"); + + my $o = mock; + ok(blessed($o), "created object"); + $c = mocked($o); + ok($c, "got control"); + + $o = mock { foo => 'foo' }; + is($o->foo, 'foo', "got the expected result"); + is($o->{foo}, 'foo', "blessed the reference"); + + $c = mock $o; + isa_ok($o, $c->class); + + + my $code = mock accessor => 'foo'; + ok(reftype($code), 'CODE', "Generated an accessor"); +}; + +subtest handlers => sub { + Test2::Tools::Mock->add_handler(__PACKAGE__, + sub { + is( + {@_}, + { + class => 'Foo', + caller => T(), + builder => T(), + args => T(), + } + ); + 1; + } + ); + + is( + dies { + mock Foo => {add => ['xxx' => sub { 'xxx' }]} + }, + undef, + "did not die" + ); +}; + +subtest set => sub { + package My::Set; + sub foo { 'foo' } + + package main; + + my $mock = mock 'My::Set' => ( + set => [ + foo => sub { 'FOO' }, + bar => sub { 'BAR' }, + ], + ); + + is(My::Set->foo, 'FOO', "overrode 'foo'"); + is(My::Set->bar, 'BAR', "injected 'bar'"); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Ref.t b/cpan/Test2-Suite/t/modules/Tools/Ref.t new file mode 100644 index 000000000000..1a11e27cf553 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Ref.t @@ -0,0 +1,94 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Ref'; + +{ + package Temp; + use Test2::Tools::Ref; + + main::imported_ok(qw/ref_ok ref_is ref_is_not/); +} + +like( + intercept { + ref_ok({}); + ref_ok({}, 'HASH', 'pass'); + ref_ok([], 'ARRAY', 'pass'); + ref_ok({}, 'ARRAY', 'fail'); + ref_ok('xxx'); + ref_ok('xxx', 'xxx'); + }, + array { + event Ok => { pass => 1 }; + event Ok => { pass => 1 }; + event Ok => { pass => 1 }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => qr/'HASH\(.*\)' is not a 'ARRAY' reference/ }; + + fail_events Ok => { pass => 0 }; + event Diag => { message => qr/'xxx' is not a reference/ }; + + fail_events Ok => { pass => 0 }; + event Diag => { message => qr/'xxx' is not a reference/ }; + + end; + }, + "ref_ok tests" +); + +my $x = []; +my $y = []; +like( + intercept { + ref_is($x, $x, 'same x'); + ref_is($x, $y, 'not same'); + + ref_is_not($x, $y, 'not same'); + ref_is_not($y, $y, 'same y'); + + ref_is('x', $x, 'no ref'); + ref_is($x, 'x', 'no ref'); + + ref_is_not('x', $x, 'no ref'); + ref_is_not($x, 'x', 'no ref'); + + ref_is(undef, $x, 'undef'); + ref_is($x, undef, 'undef'); + + ref_is_not(undef, $x, 'undef'); + ref_is_not($x, undef, 'undef'); + }, + array { + event Ok => sub { call pass => 1 }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "'$x' is not the same reference as '$y'" }; + + event Ok => sub { call pass => 1 }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "'$y' is the same reference as '$y'" }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "First argument 'x' is not a reference" }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "Second argument 'x' is not a reference" }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "First argument 'x' is not a reference" }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "Second argument 'x' is not a reference" }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "First argument '' is not a reference" }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "Second argument '' is not a reference" }; + + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "First argument '' is not a reference" }; + fail_events Ok => sub { call pass => 0 }; + event Diag => { message => "Second argument '' is not a reference" }; + + end; + }, + "Ref checks" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Spec.t b/cpan/Test2-Suite/t/modules/Tools/Spec.t new file mode 100644 index 000000000000..2edd7c15754f --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Spec.t @@ -0,0 +1,3 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Spec'; + +skip_all "Tests not yet written"; diff --git a/cpan/Test2-Suite/t/modules/Tools/Subtest.t b/cpan/Test2-Suite/t/modules/Tools/Subtest.t new file mode 100644 index 000000000000..43f66e6a7190 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Subtest.t @@ -0,0 +1,423 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Subtest'; + +use Test2::Tools::Subtest qw/subtest_streamed subtest_buffered/; + + +use File::Temp qw/tempfile/; + +# A bug in older perls causes a strange error AFTER the program appears to be +# done if this test is run. +# "Size magic not implemented." +if ($] > 5.020000 && $ENV{AUTHOR_TESTING}) { + like( + intercept { + subtest_streamed 'foo' => sub { + my ($fh, $name) = tempfile; + print $fh <<" EOT"; + use Test2::Bundle::Extended; + BEGIN { skip_all 'because' } + 1; + EOT + close($fh); + do $name; + unlink($name) or warn "Could not remove temp file $name: $!"; + die $@ if $@; + die "Ooops"; + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Subtest => sub { + field pass => 1; + field name => 'Subtest: foo'; + field subevents => subset { + event Plan => { directive => 'SKIP', reason => 'because' }; + }; + } + }, + "skip_all in BEGIN inside a subtest works" + ); +} + +subtest_streamed 'hub tests' => sub { + my $hub = Test2::API::test2_stack->top; + isa_ok($hub, 'Test2::Hub', 'Test2::Hub::Subtest'); + + my $todo = todo "testing parent_todo"; + subtest_streamed 'inner hub tests' => sub { + my $ihub = Test2::API::test2_stack->top; + isa_ok($ihub, 'Test2::Hub', 'Test2::Hub::Subtest'); + }; +}; + +like( + intercept { + subtest_streamed 'foo' => sub { + subtest_buffered 'bar' => sub { + ok(1, "pass"); + }; + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Subtest => sub { + field pass => 1; + field name => 'Subtest: foo'; + field subevents => subset { + event Subtest => sub { + field pass => 1; + field name => 'bar'; + field subevents => subset { + event Ok => sub { + field name => 'pass'; + field pass => 1; + }; + }; + }; + }; + }; + }, + "Can nest subtests" +); + +my @lines = (); +like( + intercept { + push @lines => __LINE__ + 4; + subtest_streamed 'foo' => sub { + push @lines => __LINE__ + 1; + ok(1, "pass"); + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'Subtest: foo'; + field subevents => subset { + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'pass'; + field pass => 1; + }; + }; + }; + }, + "Got events for passing subtest" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 4; + subtest_streamed 'foo' => sub { + push @lines => __LINE__ + 1; + ok(0, "fail"); + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 0; + field name => 'Subtest: foo'; + field subevents => subset { + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'fail'; + field pass => 0; + }; + }; + }; + }, + "Got events for failing subtest" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 5; + subtest_streamed 'foo' => sub { + push @lines => __LINE__ + 1; + ok(1, "pass"); + done_testing; + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'Subtest: foo'; + field subevents => subset { + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'pass'; + field pass => 1; + }; + event Plan => { max => 1 }; + }; + }; + }, + "Can use done_testing" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 5; + subtest_streamed 'foo' => sub { + plan 1; + push @lines => __LINE__ + 1; + ok(1, "pass"); + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'Subtest: foo'; + field subevents => subset { + event Plan => { max => 1 }; + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'pass'; + field pass => 1; + }; + }; + }; + }, + "Can plan" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 5; + subtest_streamed 'foo' => sub { + skip_all 'bleh'; + push @lines => __LINE__ + 1; + ok(1, "pass"); + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'Subtest: foo'; + field subevents => subset { + event Plan => { directive => 'SKIP', reason => 'bleh' }; + }; + }; + }, + "Can skip_all" +); + +@lines = (); +like( + intercept { + subtest_streamed 'foo' => sub { + bail_out 'cause'; + ok(1, "should not see this"); + }; + }, + subset { + event Note => { message => 'Subtest: foo' }; + event Bail => { reason => 'cause' }; + }, + "Can bail out" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 4; + subtest_buffered 'foo' => sub { + push @lines => __LINE__ + 1; + ok(1, "pass"); + }; + }, + subset { + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'foo'; + field subevents => subset { + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'pass'; + field pass => 1; + }; + }; + }; + }, + "Got events for passing subtest" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 4; + subtest_buffered 'foo' => sub { + push @lines => __LINE__ + 1; + ok(0, "fail"); + }; + }, + subset { + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 0; + field name => 'foo'; + field subevents => subset { + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'fail'; + field pass => 0; + }; + }; + }; + }, + "Got events for failing subtest" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 5; + subtest_buffered 'foo' => sub { + push @lines => __LINE__ + 1; + ok(1, "pass"); + done_testing; + }; + }, + subset { + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'foo'; + field subevents => subset { + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'pass'; + field pass => 1; + }; + event Plan => { max => 1 }; + }; + }; + }, + "Can use done_testing" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 5; + subtest_buffered 'foo' => sub { + plan 1; + push @lines => __LINE__ + 1; + ok(1, "pass"); + }; + }, + subset { + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'foo'; + field subevents => subset { + event Plan => { max => 1 }; + event Ok => sub { + prop file => __FILE__; + prop line => $lines[1]; + field name => 'pass'; + field pass => 1; + }; + }; + }; + }, + "Can plan" +); + +@lines = (); +like( + intercept { + push @lines => __LINE__ + 5; + subtest_buffered 'foo' => sub { + skip_all 'bleh'; + push @lines => __LINE__ + 1; + ok(1, "pass"); + }; + }, + subset { + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'foo'; + field subevents => subset { + event Plan => { directive => 'SKIP', reason => 'bleh' }; + }; + }; + }, + "Can skip_all" +); + +@lines = (); +like( + intercept { + subtest_buffered 'foo' => sub { + bail_out 'cause'; + ok(1, "should not see this"); + }; + }, + subset { + event Bail => { reason => 'cause' }; + }, + "Can bail out" +); + +@lines = (); +my $xyz = 0; +like( + intercept { + push @lines => __LINE__ + 5; + subtest_buffered 'foo' => {manual_skip_all => 1}, sub { + skip_all 'bleh'; + $xyz = 1; + return; + }; + }, + subset { + event Subtest => sub { + prop file => __FILE__; + prop line => $lines[0]; + field pass => 1; + field name => 'foo'; + field subevents => subset { + event Plan => { directive => 'SKIP', reason => 'bleh' }; + }; + }; + }, + "Can skip_all" +); +ok($xyz, "skip_all did not auto-abort"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Target.t b/cpan/Test2-Suite/t/modules/Tools/Target.t new file mode 100644 index 000000000000..2f28645b14fd --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Target.t @@ -0,0 +1,13 @@ +use Test2::Bundle::Extended; + +use Test2::Tools::Target 'Test2::Tools::Target'; + +is($CLASS, 'Test2::Tools::Target', "set default var"); +is(CLASS(), 'Test2::Tools::Target', "set default const"); + +use Test2::Tools::Target FOO => 'Test2::Tools::Target'; + +is($FOO, 'Test2::Tools::Target', "set custom var"); +is(FOO(), 'Test2::Tools::Target', "set custom const"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/01count.t b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/01count.t new file mode 100644 index 000000000000..d18395dc335c --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/01count.t @@ -0,0 +1,125 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test2::API; +use Test2::Tools::Basic; +use Test2::API qw(intercept context); +use Test2::Tools::Compare qw/match subset array event like/; + +use Test2::Tools::Refcount; + +my $anon = []; + +like( + intercept { + is_refcount($anon, 1, 'anon ARRAY ref'); + }, + array { + event Ok => { name => 'anon ARRAY ref', pass => 1 }; + }, + 'anon ARRAY ref succeeds' +); + +like( + intercept { + is_refcount("hello", 1, 'not ref'); + }, + array { + event Ok => { name => 'not ref', pass => 0 }; + event Diag => { message => match qr/Failed test 'not ref'/ }; + event Diag => { message => " expected a reference, was not given one" }; + }, + 'not ref fails', +); + +my $object = bless {}, "Some::Class"; + +like( + intercept { + is_refcount($object, 1, 'object'); + }, + array { + event Ok => { name => 'object', pass => 1 }; + }, + 'normal object succeeds', +); + +my $newref = $object; + +like( + intercept { + is_refcount($object, 2, 'two refs'); + }, + array { + event Ok => { name => 'two refs', pass => 1 }; + }, + 'two refs to object succeeds', +); + +like( + intercept { + is_refcount($object, 1, 'one ref'); + }, + subset { + event Ok => { name => 'one ref', pass => 0 }; + event Diag => { message => match qr/Failed test 'one ref'/ }; + event Diag => { message => match qr/expected 1 references, found 2/ }; + + if (Test2::Tools::Refcount::HAVE_DEVEL_MAT_DUMPER) { + event Diag => { message => match qr/SV address is 0x[0-9a-f]+/ }; + event Diag => { message => match qr/Writing heap dump to \S+/ }; + } + }, + "two refs to object fails to be 1" +); + +undef $newref; + +$object->{self} = $object; + +like( + intercept { + is_refcount($object, 2, 'circular'); + }, + array { + event Ok => { name => 'circular', pass => 1 }; + }, + 'circular object succeeds', +); + +undef $object->{self}; + +my $otherobject = bless { firstobject => $object }, "Other::Class"; + +like( + intercept { + is_refcount($object, 2, 'other ref to object'); + }, + array { + event Ok => { name => 'other ref to object', pass => 1 }; + }, + 'object with another reference succeeds', +); + +undef $otherobject; + +like( + intercept { + is_refcount($object, 1, 'undefed other ref to object' ); + }, + array { + event Ok => { name => 'undefed other ref to object', pass => 1 }; + }, + 'object with another reference undefed succeeds', +); + +END { + # Clean up Devel::MAT dumpfile + my $pmat = $0; + $pmat =~ s/\.t$/-1.pmat/; + unlink $pmat if -f $pmat; +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/02one.t b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/02one.t new file mode 100644 index 000000000000..0016e14e1be6 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/02one.t @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test2::API; +use Test2::Tools::Basic; +use Test2::API qw(intercept context); +use Test2::Tools::Compare qw/match subset array event like/; + +use Test2::Tools::Refcount; + +my $anon = []; + +like( + intercept { + is_oneref($anon, 'anon ARRAY ref'); + }, + array { + event Ok => { name => 'anon ARRAY ref', pass => 1 }; + }, + 'anon ARRAY ref succeeds' +); + +my $object = bless {}, "Some::Class"; + +like( + intercept { + is_oneref($object, 'object'); + }, + array { + event Ok => { name => 'object', pass => 1 }; + }, + 'normal object succeeds', +); + +my $newref = $object; + +like( + intercept { + is_oneref($object, 'one ref'); + }, + subset { + event Ok => { name => 'one ref', pass => 0 }; + event Diag => { message => match qr/Failed test 'one ref'/ }; + event Diag => { message => match qr/expected 1 references, found 2/ }; + + if (Test2::Tools::Refcount::HAVE_DEVEL_MAT_DUMPER) { + event Diag => { message => match qr/SV address is 0x[0-9a-f]+/ }; + event Diag => { message => match qr/Writing heap dump to \S+/ }; + } + }, + "two refs to object fails to be 1" +); + +END { + # Clean up Devel::MAT dumpfile + my $pmat = $0; + $pmat =~ s/\.t$/-1.pmat/; + unlink $pmat if -f $pmat; +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/03weak.t b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/03weak.t new file mode 100644 index 000000000000..6338d160d089 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/03weak.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test2::API; +use Test2::Tools::Basic; +use Test2::API qw(intercept context); +use Test2::Tools::Compare qw/match subset array event like/; + +use Scalar::Util qw( weaken ); + +use Test2::Tools::Refcount; + +my $object = bless {}, "Some::Class"; + +my $newref = $object; + +like( + intercept { + is_oneref($object, 'one ref'); + }, + subset { + event Ok => { name => 'one ref', pass => 0 }; + event Diag => { message => match qr/Failed test 'one ref'/ }; + event Diag => { message => match qr/expected 1 references, found 2/ }; + + if (Test2::Tools::Refcount::HAVE_DEVEL_MAT_DUMPER) { + event Diag => { message => match qr/SV address is 0x[0-9a-f]+/ }; + event Diag => { message => match qr/Writing heap dump to \S+/ }; + } + }, + "two refs to object fails to be 1" +); + +weaken( $newref ); + +like( + intercept { + is_oneref($object, 'object with weakref'); + }, + array { + event Ok => { name => 'object with weakref', pass => 1 }; + }, + 'object with weakref succeeds' +); + +END { + # Clean up Devel::MAT dumpfile + my $pmat = $0; + $pmat =~ s/\.t$/-1.pmat/; + unlink $pmat if -f $pmat; +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/04reftypes.t b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/04reftypes.t new file mode 100644 index 000000000000..dda2ac3aaa6a --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Test-Refcount/04reftypes.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test2::API; +use Test2::Tools::Basic; +use Test2::API qw(intercept context); +use Test2::Tools::Compare qw/match subset array event like/; + +use Symbol qw( gensym ); + +use Test2::Tools::Refcount; + +my %refs = ( + SCALAR => do { my $var; \$var }, + ARRAY => [], + HASH => +{}, + # This magic is to ensure the code ref is new, not shared. To be a new one + # it has to contain a unique pad. + CODE => do { my $var; sub { $var } }, + GLOB => gensym(), + Regex => qr/foo/, +); + +foreach my $type (qw( SCALAR ARRAY HASH CODE GLOB Regex )) { + SKIP: { + if( $type eq "Regex" and $] >= 5.011 ) { + # Perl v5.11 seems to have odd behaviour with Regexp references. They start + # off with a refcount of 2. Not sure if this is a bug in Perl, or my + # assumption. Until P5P have worked it out, we'll skip this. See also + # similar skip logic in Devel-Refcount's tests + skip "Bleadperl", 1; + } + + like( + intercept { + is_refcount($refs{$type}, 1, "anon $type ref"); + }, + array { + event Ok => { name => "anon $type ref", pass => 1 }; + }, + 'anon ARRAY ref succeeds' + ); + } +} + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Tester.t b/cpan/Test2-Suite/t/modules/Tools/Tester.t new file mode 100644 index 000000000000..db290b787846 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Tester.t @@ -0,0 +1,165 @@ +use Test2::V0; +use Test2::Tools::Tester qw/event_groups filter_events facets/; +use Scalar::Util qw/blessed/; + +my $funky = sub { + my $ctx = context(); + + $ctx->send_event( + Generic => ( + facet_data => { + funk1 => {details => 'funk1'}, + funk2 => [{details => 'funk2'}, {details => 'more funk2'}], + }, + ), + ); + $ctx->release; +}; + +subtest event_groups => sub { + my $anon = sub { + my $ctx = context(); + + $ctx->pass_and_release('foo'); + }; + + my $events = intercept { + plan 11; + + pass('pass'); + ok(1, 'pass'); + + is(1, 1, "pass"); + like(1, 1, "pass"); + + $anon->(); + $anon->(); + + $funky->(); + }; + + my $groups = event_groups($events); + + is( + $groups, + { + '__NA__' => [$events->[-1]], + 'Test2::Tools::Basic' => { + '__ALL__' => [@{$events}[0, 1, 2]], + 'plan' => [$events->[0]], + 'pass' => [$events->[1]], + 'ok' => [$events->[2]], + }, + 'Test2::Tools::Compare' => { + '__ALL__' => [@{$events}[3, 4]], + 'is' => [$events->[3]], + 'like' => [$events->[4]], + }, + 'main' => { + '__ALL__' => [@{$events}[5, 6]], + '__ANON__' => [@{$events}[5, 6]], + }, + }, + "Events were grouped properly" + ); +}; + +subtest filter_events => sub { + my $events = intercept { + ok(1, "pass"); + ok(0, "fail"); + + is(1, 1, "pass"); + is(1, 2, "fail"); + }; + + my $basic = filter_events $events => 'Test2::Tools::Basic'; + my $compare = filter_events $events => 'Test2::Tools::Compare'; + + is(@$basic, 3, "First 2 events (and a diag) are from vasic tools"); + is(@$compare, @$events - @$basic, "Other events are from compare"); + + is( + $basic, + [@{$events}[0, 1, 2]], + "Verify the correct events are in the basic group" + ); + + my $basic2 = filter_events $events => qr/ok$/; + is($basic2, $basic, "Can use a regex for a filter"); +}; + +subtest facets => sub { + my $events = intercept { + ok(1, "pass"); + ok(0, "fail"); + diag "xxx"; + note "yyy"; + + $funky->(); + + my $it = sub { + my $ctx = context(); + $ctx->send_event( + Generic => ( + facet_data => { + errors => [ + {fatal => 1, details => "a fatal error", tag => 'error'}, + {fatal => 0, details => "just an error", tag => 'error'}, + ] + } + ) + ); + $ctx->release; + }; + $it->(); + }; + + my $a_facets = facets assert => $events; + my $i_facets = facets info => $events; + my $e1_facets = facets error => $events; + my $e2_facets = facets errors => $events; + my $funk1 = facets funk1 => $events; + my $funk2 = facets funk2 => $events; + + like( + $a_facets, + array { + item { details => 'pass', pass => 1 }; + item { details => 'fail', pass => 0 }; + end; + }, + "Got both assertions" + ); + + isa_ok($a_facets->[0], ['Test2::EventFacet::Assert'], "Blessed the facet"); + + like( + $i_facets, + array { + item {details => qr/Failed test/, tag => 'DIAG'}; + item {details => 'xxx', tag => 'DIAG'}; + item {details => 'yyy', tag => 'NOTE'}; + end; + }, + "Got the info facets" + ); + + like( + $e1_facets, + array { + item {fatal => 1, details => "a fatal error", tag => 'error'}; + item {fatal => 0, details => "just an error", tag => 'error'}; + end; + }, + "Got error facets" + ); + + is($e1_facets, $e2_facets, "Can get facet by either the name or the key"); + + is($funk1, [{details => 'funk1'}], "Can use unknown facet type"); + is($funk2, [{details => 'funk2'}, {details => 'more funk2'}], "Can use unknown list facet type"); + ok(!blessed($funk1->[0]), "Did not bless the unknown type"); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Tools/Warnings.t b/cpan/Test2-Suite/t/modules/Tools/Warnings.t new file mode 100644 index 000000000000..6dd7ecb9048b --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Tools/Warnings.t @@ -0,0 +1,62 @@ +use Test2::Bundle::Extended -target => 'Test2::Tools::Warnings'; + +{ + package Foo; + use Test2::Tools::Warnings qw/warns warning warnings no_warnings/; + ::imported_ok(qw/warns warning warnings no_warnings/); +} + +is(warns { 0 }, 0, "no warnings"); +is(warns { warn 'a' }, 1, "1 warning"); +is(warns { warn 'a' for 1 .. 4 }, 4, "4 warnings"); + +ok(no_warnings { 0 }, "no warnings"); +ok(!no_warnings { warn 'a' }, "warnings"); + +is( + warnings { 0 }, + [], + "Empty arrayref" +); + +is( + warnings { warn "a\n" for 1 .. 4 }, + [ map "a\n", 1 .. 4 ], + "4 warnings in arrayref" +); + +is( + warning { warn "xyz\n" }, + "xyz\n", + "Got expected warning" +); + +is( + warning { 0 }, + undef, + "No warning" +); + +my ($events, $warn); +$events = intercept { + $warn = warning { + warning { warn "a\n"; warn "b\n" }; + }; +}; + +like( + $warn, + qr/Extra warnings in warning \{ \.\.\. \}/, + "Got warning about extra warnings" +); + +like( + $events, + array { + event Note => { message => "a\n" }; + event Note => { message => "b\n" }; + }, + "Got warnings as notes." +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Grabber.t b/cpan/Test2-Suite/t/modules/Util/Grabber.t new file mode 100644 index 000000000000..e8fefcb21a2e --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Grabber.t @@ -0,0 +1,33 @@ +use Test2::Bundle::Extended -target => 'Test2::Util::Grabber'; + +ok(1, "initializing"); + +my $grab = $CLASS->new; +ok(1, "pass"); +my $one = $grab->events; +ok(0, "fail"); +my $events = $grab->finish; + +is(@$one, 1, "Captured 1 event"); +is(@$events, 3, "Captured 3 events"); + +like( + $one, + array { + event Ok => { pass => 1 }; + }, + "Got expected event" +); + +like( + $events, + array { + event Ok => { pass => 1 }; + event Ok => { pass => 0 }; + event Diag => { }; + end; + }, + "Got expected events" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Ref.t b/cpan/Test2-Suite/t/modules/Util/Ref.t new file mode 100644 index 000000000000..f843e6cef836 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Ref.t @@ -0,0 +1,34 @@ +use Test2::Bundle::Extended; + +use Test2::Util::Ref qw/rtype render_ref/; + +imported_ok qw{ render_ref rtype }; + +{ + package Test::A; + package Test::B; + use overload '""' => sub { 'A Bee!' }; +} +my $ref = {a => 1}; +is(render_ref($ref), "$ref", "Matches normal stringification (not blessed)"); +like(render_ref($ref), qr/HASH\(0x[0-9A-F]+\)/i, "got address"); + +bless($ref, 'Test::A'); +is(render_ref($ref), "$ref", "Matches normal stringification (blessed)"); +like(render_ref($ref), qr/Test::A=HASH\(0x[0-9A-F]+\)/i, "got address and package (no overload)"); + +bless($ref, 'Test::B'); +like(render_ref($ref), qr/Test::B=HASH\(0x[0-9A-F]+\)/i, "got address and package (with overload)"); + +my $x = ''; +$ref = \$x; +is(rtype(undef), '', "not a ref"); +is(rtype(''), '', "not a ref"); +is(rtype({}), 'HASH', "HASH"); +is(rtype([]), 'ARRAY', "ARRAY"); +is(rtype($ref), 'SCALAR', "SCALAR"); +is(rtype(\$ref), 'REF', "REF"); +is(rtype(sub { 1 }), 'CODE', "CODE"); +is(rtype(qr/xxx/), 'REGEXP', "REGEXP"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Stash.t b/cpan/Test2-Suite/t/modules/Util/Stash.t new file mode 100644 index 000000000000..49053c399707 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Stash.t @@ -0,0 +1,153 @@ +use Test2::Bundle::Extended -target => 'Test2::Util::Stash'; + +use Test2::Util::Stash qw{ + get_stash + get_glob + get_symbol + parse_symbol + purge_symbol + slot_to_sig sig_to_slot +}; + +imported_ok qw{ + get_stash + get_glob + get_symbol + parse_symbol + purge_symbol + slot_to_sig sig_to_slot +}; + +is(slot_to_sig('CODE'), '&', "Code slot sigil"); +is(slot_to_sig('SCALAR'), '$', "Scalar slot sigil"); +is(slot_to_sig('HASH'), '%', "Hash slot sigil"); +is(slot_to_sig('ARRAY'), '@', "Array slot sigil"); + +is(sig_to_slot('&'), 'CODE', "Code slot sigil"); +is(sig_to_slot('$'), 'SCALAR', "Scalar slot sigil"); +is(sig_to_slot('%'), 'HASH', "Hash slot sigil"); +is(sig_to_slot('@'), 'ARRAY', "Array slot sigil"); + +is(get_stash('main'), string(\%main::), "got stash"); +is(get_glob('main::ok'), \*main::ok, "got glob ref"); + +is( + parse_symbol("foo"), + { + name => 'foo', + sigil => '&', + type => 'CODE', + symbol => '&main::foo', + package => 'main', + }, + "Parsed simple sub" +); + +is( + parse_symbol("&foo"), + { + name => 'foo', + sigil => '&', + type => 'CODE', + symbol => '&main::foo', + package => 'main', + }, + "Parsed simple sub with sigil" +); + +is( + parse_symbol("&::foo"), + { + name => 'foo', + sigil => '&', + type => 'CODE', + symbol => '&main::foo', + package => 'main', + }, + "Parsed ::sub with sigil" +); + +is( + parse_symbol("&Foo::Bar::foo"), + { + name => 'foo', + sigil => '&', + type => 'CODE', + symbol => '&Foo::Bar::foo', + package => 'Foo::Bar', + }, + "Parsed sub with package" +); + +is( + parse_symbol('$foo'), + { + name => 'foo', + sigil => '$', + type => 'SCALAR', + symbol => '$main::foo', + package => 'main', + }, + "Parsed scalar" +); + +is( + parse_symbol('%foo'), + { + name => 'foo', + sigil => '%', + type => 'HASH', + symbol => '%main::foo', + package => 'main', + }, + "Parsed hash" +); + +is( + parse_symbol('@foo'), + { + name => 'foo', + sigil => '@', + type => 'ARRAY', + symbol => '@main::foo', + package => 'main', + }, + "Parsed array" +); + +is( + parse_symbol('@foo', 'XYZ::ABC'), + { + name => 'foo', + sigil => '@', + type => 'ARRAY', + symbol => '@XYZ::ABC::foo', + package => 'XYZ::ABC', + }, + "Parsed with custom package" +); + +like( + dies { parse_symbol('ABC::foo', 'XYZ') }, + qr/Symbol package \(ABC\) and package argument \(XYZ\) do not match/, + "Got exception" +); + +like( + dies { parse_symbol({package => 'ABC'}, 'XYZ') }, + qr/Symbol package \(ABC\) and package argument \(XYZ\) do not match/, + "Got exception" +); + +sub xxx { 'xxx' } +our $foo = 'xyz'; +ref_is(get_symbol('xxx'), \&xxx, "got ref for &xxx"); +ref_is(get_symbol('$foo'), \$foo, 'got ref for $foo'); +is(get_symbol('blah'), undef, 'no ref for &blah'); +is(get_symbol('$blah'), undef, 'no ref for $blah'); + +purge_symbol('xxx'); +ok(!__PACKAGE__->can('xxx'), "removed &xxx symbol test 1"); +is(get_symbol('xxx'), undef, "removed &xxx symbol test 2"); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Sub.t b/cpan/Test2-Suite/t/modules/Util/Sub.t new file mode 100644 index 000000000000..e24ad2c46c9c --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Sub.t @@ -0,0 +1,34 @@ +use Test2::Bundle::Extended; + +use Test2::Util::Sub qw{ + sub_name +}; + +imported_ok qw{ + sub_name +}; + +sub named { 'named' } +*unnamed = sub { 'unnamed' }; +like(sub_name(\&named), qr/named$/, "got sub name (named)"); +like(sub_name(\&unnamed), qr/__ANON__$/, "got sub name (anon)"); + +like( + dies { sub_name() }, + qr/sub_name requires a coderef as its only argument/, + "Need an arg" +); + +like( + dies { sub_name('xxx') }, + qr/sub_name requires a coderef as its only argument/, + "Need a ref" +); + +like( + dies { sub_name({}) }, + qr/sub_name requires a coderef as its only argument/, + "Need a code ref" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Table.t b/cpan/Test2-Suite/t/modules/Util/Table.t new file mode 100644 index 000000000000..0083b738bb5a --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Table.t @@ -0,0 +1,271 @@ +use Test2::Bundle::Extended; +BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } +use Test2::Util::Table qw/table/; +use Test2::Util::Term qw/USE_GCS/; + +imported_ok qw/table/; + +subtest unicode_display_width => sub { + my $wide = "foo bar baz 婧"; + + my $have_gcstring = eval { require Unicode::GCString; 1 }; + + subtest no_unicode_linebreak => sub { + my @table = table('header' => [ 'a', 'b'], 'rows' => [[ '婧', '߃' ]]); + + like( + \@table, + ["Unicode::GCString is not installed, table may not display all unicode characters properly"], + "got unicode note" + ); + } unless USE_GCS; + + subtest with_unicode_linebreak => sub { + my @table = table( + 'header' => [ 'a', 'b'], + 'rows' => [[ 'a婧b', '߃' ]], + 'max_width' => 80, + ); + is( + \@table, + [ + '+------+---+', + '| a | b |', + '+------+---+', + '| a婧b | ߃ |', + '+------+---+', + ], + "Support for unicode characters that use multiple columns" + ); + } if USE_GCS; +}; + +subtest width => sub { + my @table = table( + max_width => 40, + header => [ 'a', 'b', 'c', 'd' ], + rows => [ + [ qw/aaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccccc ddddddddddddddddddddddddddddd/ ], + [ qw/AAAAAAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBB CCCCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDDDDDDDD/ ], + ], + ); + + is(length($table[0]), validator('<=', '40', sub { my %p = @_; $p{got} <= $p{name} }), "width of table"); + + is( + \@table, + [ + '+-------+-------+-------+-------+', + '| a | b | c | d |', + '+-------+-------+-------+-------+', + '| aaaaa | bbbbb | ccccc | ddddd |', + '| aaaaa | bbbbb | ccccc | ddddd |', + '| aaaaa | bbbbb | ccccc | ddddd |', + '| aaaaa | bbbbb | ccccc | ddddd |', + '| aaaaa | b | ccc | ddddd |', + '| a | | | dddd |', + '| | | | |', + '| AAAAA | BBBBB | CCCCC | DDDDD |', + '| AAAAA | BBBBB | CCCCC | DDDDD |', + '| AAAAA | BBBBB | CCCCC | DDDDD |', + '| AAAAA | BBBBB | CCCCC | DDDDD |', + '| AAAAA | B | CCC | DDDDD |', + '| A | | | DDDD |', + '+-------+-------+-------+-------+', + ], + "Basic table, small width" + ); + + @table = table( + max_width => 60, + header => [ 'a', 'b', 'c', 'd' ], + rows => [ + [ qw/aaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccccc ddddddddddddddddddddddddddddd/ ], + [ qw/AAAAAAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBB CCCCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDDDDDDDD/ ], + ], + ); + + is(length($table[0]), validator('<=', '60', sub { my %p = @_; $p{got} <= $p{name} }), "width of table"); + + is( + \@table, + [ + '+------------+------------+------------+------------+', + '| a | b | c | d |', + '+------------+------------+------------+------------+', + '| aaaaaaaaaa | bbbbbbbbbb | cccccccccc | dddddddddd |', + '| aaaaaaaaaa | bbbbbbbbbb | cccccccccc | dddddddddd |', + '| aaaaaa | b | ccc | ddddddddd |', + '| | | | |', + '| AAAAAAAAAA | BBBBBBBBBB | CCCCCCCCCC | DDDDDDDDDD |', + '| AAAAAAAAAA | BBBBBBBBBB | CCCCCCCCCC | DDDDDDDDDD |', + '| AAAAAA | B | CCC | DDDDDDDDD |', + '+------------+------------+------------+------------+', + ], + "Basic table, bigger width" + ); + + @table = table( + max_width => 60, + header => [ 'a', 'b', 'c', 'd' ], + rows => [ + [ qw/aaaa bbbb cccc dddd/ ], + [ qw/AAAA BBBB CCCC DDDD/ ], + ], + ); + + is(length($table[0]), validator('<=', '60', sub { my %p = @_; $p{got} <= $p{name} }), "width of table"); + + is( + \@table, + [ + '+------+------+------+------+', + '| a | b | c | d |', + '+------+------+------+------+', + '| aaaa | bbbb | cccc | dddd |', + '| AAAA | BBBB | CCCC | DDDD |', + '+------+------+------+------+', + ], + "Short table, well under minimum", + ); +}; + +subtest collapse => sub { + my @table = table( + max_width => 60, + collapse => 1, + header => [ 'a', 'b', 'c', 'd' ], + rows => [ + [ qw/aaaa bbbb/, undef, qw/dddd/ ], + [ qw/AAAA BBBB/, '', qw/DDDD/ ], + ], + ); + + is( + \@table, + [ + '+------+------+------+', + '| a | b | d |', + '+------+------+------+', + '| aaaa | bbbb | dddd |', + '| AAAA | BBBB | DDDD |', + '+------+------+------+', + ], + "Table collapsed", + ); + + @table = table( + max_width => 60, + header => [ 'a', 'b', 'c', 'd' ], + rows => [ + [ qw/aaaa bbbb/, undef, qw/dddd/ ], + [ qw/AAAA BBBB/, '', qw/DDDD/ ], + ], + ); + + is( + \@table, + [ + '+------+------+---+------+', + '| a | b | c | d |', + '+------+------+---+------+', + '| aaaa | bbbb | | dddd |', + '| AAAA | BBBB | | DDDD |', + '+------+------+---+------+', + ], + "Table not collapsed", + ); + + @table = table( + max_width => 60, + collapse => 1, + header => [ 'a', 'b', 'c', 'd' ], + rows => [ + [ qw/aaaa bbbb/, undef, qw/dddd/ ], + [ qw/AAAA BBBB/, 0, qw/DDDD/ ], + ], + ); + + is( + \@table, + [ + '+------+------+---+------+', + '| a | b | c | d |', + '+------+------+---+------+', + '| aaaa | bbbb | | dddd |', + '| AAAA | BBBB | 0 | DDDD |', + '+------+------+---+------+', + ], + "'0' value does not cause collapse", + ); + +}; + +subtest header => sub { + my @table = table( + max_width => 60, + header => [ 'a', 'b', 'c', 'd' ], + rows => [ + [ qw/aaaa bbbb cccc dddd/ ], + [ qw/AAAA BBBB CCCC DDDD/ ], + ], + ); + + is( + \@table, + [ + '+------+------+------+------+', + '| a | b | c | d |', + '+------+------+------+------+', + '| aaaa | bbbb | cccc | dddd |', + '| AAAA | BBBB | CCCC | DDDD |', + '+------+------+------+------+', + ], + "Table with header", + ); +}; + +subtest no_header => sub { + my @table = table( + max_width => 60, + rows => [ + [ qw/aaaa bbbb cccc dddd/ ], + [ qw/AAAA BBBB CCCC DDDD/ ], + ], + ); + + is( + \@table, + [ + '+------+------+------+------+', + '| aaaa | bbbb | cccc | dddd |', + '| AAAA | BBBB | CCCC | DDDD |', + '+------+------+------+------+', + ], + "Table without header", + ); +}; + +subtest mark_tail => sub { + my @table = table( + max_width => 60, + mark_tail => 1, + header => [ 'data1', 'data2' ], + rows => [[" abc def ", " abc def \t"]], + ); + + is( + \@table, + [ + '+----------------------+----------------+', + '| data1 | data2 |', + '+----------------------+----------------+', + '| abc def \N{U+20} | abc def \t |', + '+----------------------+----------------+', + ], + "Sanitized data" + ); + +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Table/Cell.t b/cpan/Test2-Suite/t/modules/Util/Table/Cell.t new file mode 100644 index 000000000000..88c2ae62eff4 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Table/Cell.t @@ -0,0 +1,37 @@ +use Test2::Bundle::Extended -target => 'Test2::Util::Table::Cell'; + +subtest sanitization => sub { + my $unsanitary = <<" EOT"; +This string +has vertical space +including        

　‌\N{U+000B}unicode stuff +and some non-whitespace ones: 婧 ʶ ๖ + EOT + my $sanitary = 'This string\nhas vertical space\nincluding\N{U+A0}\N{U+1680}\N{U+2000}\N{U+2001}\N{U+2002}\N{U+2003}\N{U+2004}\N{U+2008}\N{U+2028}\N{U+2029}\N{U+3000}\N{U+200C}\N{U+FEFF}\N{U+B}unicode stuff\nand some non-whitespace ones: 婧 ʶ ๖\n'; + $sanitary =~ s/\\n/\\n\n/g; + + local *show_char = sub { Test2::Util::Table::Cell->show_char(@_) }; + + # Common control characters + is(show_char("\a"), '\a', "translated bell"); + is(show_char("\b"), '\b', "translated backspace"); + is(show_char("\e"), '\e', "translated escape"); + is(show_char("\f"), '\f', "translated formfeed"); + is(show_char("\n"), "\\n\n", "translated newline"); + is(show_char("\r"), '\r', "translated return"); + is(show_char("\t"), '\t', "translated tab"); + is(show_char(" "), ' ', "plain space is not translated"); + + # unicodes + is(show_char("婧"), '\N{U+5A67}', "translated unicode 婧 (U+5A67)"); + is(show_char("ʶ"), '\N{U+2B6}', "translated unicode ʶ (U+2B6)"); + is(show_char("߃"), '\N{U+7C3}', "translated unicode ߃ (U+7C3)"); + is(show_char("๖"), '\N{U+E56}', "translated unicode ๖ (U+E56)"); + + my $cell = CLASS->new(value => $unsanitary); + $cell->sanitize; + + is($cell->value, $sanitary, "Sanitized string"); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Table/LineBreak.t b/cpan/Test2-Suite/t/modules/Util/Table/LineBreak.t new file mode 100644 index 000000000000..c6ced1b6edd3 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Table/LineBreak.t @@ -0,0 +1,75 @@ +use Test2::Bundle::Extended; +use Test2::Util::Table::LineBreak; + +BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } + +subtest with_unicode_linebreak => sub { + my $one = Test2::Util::Table::LineBreak->new(string => 'aaaa婧bbbb'); + $one->break(3); + is( + [ map { $one->next } 1 .. 5 ], + [ + 'aaa', + 'a婧', + 'bbb', + 'b ', + undef + ], + "Got all parts" + ); + + $one = Test2::Util::Table::LineBreak->new(string => 'a婧bb'); + $one->break(2); + is( + [ map { $one->next } 1 .. 4 ], + [ + 'a ', + '婧', + 'bb', + undef + ], + "Padded the problem" + ); + +} if $INC{'Unicode/LineBreak.pm'}; + +subtest without_unicode_linebreak => sub { + my @parts; + { + local %INC = %INC; + delete $INC{'Unicode/GCString.pm'}; + my $one = Test2::Util::Table::LineBreak->new(string => 'aaaa婧bbbb'); + $one->break(3); + @parts = map { $one->next } 1 .. 5; + } + + todo "Can't handle unicode properly without Unicode::GCString" => sub { + is( + \@parts, + [ + 'aaa', + 'a婧', + 'bbb', + 'b ', + undef + ], + "Got all parts" + ); + }; + + my $one = Test2::Util::Table::LineBreak->new(string => 'aaabbbx'); + $one->break(2); + is( + [ map { $one->next } 1 .. 5 ], + [ + 'aa', + 'ab', + 'bb', + 'x ', + undef + ], + "Padded the problem" + ); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Util/Times.t b/cpan/Test2-Suite/t/modules/Util/Times.t new file mode 100644 index 000000000000..aad1dd4dda67 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Util/Times.t @@ -0,0 +1,39 @@ +use Test2::Bundle::Extended; + +use Test2::Util::Times qw/render_bench/; + +imported_ok qw{ render_bench }; + +sub TM() { 0.5 } + +is( + render_bench(0, 2.123456, TM, TM, TM, TM), + "2.12346s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", + "Got benchmark with < 10 second duration" +); + +is( + render_bench(0, 42.123456, TM, TM, TM, TM), + "42.1235s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", + "Got benchmark with < 1 minute duration" +); + +is( + render_bench(0, 422.123456, TM, TM, TM, TM), + "07m:02.12s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", + "Got benchmark with minute+ duration" +); + +is( + render_bench(0, 10422.123456, TM, TM, TM, TM), + "02h:53m:42.12s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", + "Got benchmark with hour+ duration" +); + +is( + render_bench(0, 501023.123456, TM, TM, TM, TM), + "05d:19h:10m:23.12s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", + "Got benchmark with day+ duration" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/V0.t b/cpan/Test2-Suite/t/modules/V0.t new file mode 100644 index 000000000000..b56deac306c5 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/V0.t @@ -0,0 +1,96 @@ +use Test2::V0; +use Test2::API qw/test2_stack/; +use PerlIO; +# HARNESS-NO-FORMATTER + +imported_ok qw{ + ok pass fail diag note todo skip + plan skip_all done_testing bail_out + + gen_event + + intercept context + + cmp_ok + + subtest + can_ok isa_ok DOES_ok + set_encoding + imported_ok not_imported_ok + ref_ok ref_is ref_is_not + mock mocked + + dies lives try_ok + + is like isnt unlike + match mismatch validator + hash array object meta number string bool check_isa + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event fail_events + exact_ref + + is_refcount is_oneref refcount +}; + +ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); +ok(defined(Test2::Plugin::SRand->seed), "SRand is loaded"); + +subtest strictures => sub { + local $^H; + my $hbefore = $^H; + Test2::V0->import; + my $hafter = $^H; + + my $strict = do { local $^H; strict->import(); $^H }; + + ok($strict, 'sanity, got $^H value for strict'); + ok(!($hbefore & $strict), "strict is not on before loading Test2::V0"); + ok(($hafter & $strict), "strict is on after loading Test2::V0"); +}; + +subtest warnings => sub { + local ${^WARNING_BITS}; + my $wbefore = ${^WARNING_BITS} || ''; + Test2::V0->import; + my $wafter = ${^WARNING_BITS} || ''; + + my $warnings = do { local ${^WARNING_BITS}; 'warnings'->import(); ${^WARNING_BITS} || '' }; + + ok($warnings, 'sanity, got ${^WARNING_BITS} value for warnings'); + ok($wbefore ne $warnings, "warnings are not on before loading Test2::V0") || diag($wbefore, "\n", $warnings); + ok(($wafter & $warnings), "warnings are on after loading Test2::V0"); +}; + +subtest utf8 => sub { + ok(utf8::is_utf8("癸"), "utf8 pragma is on"); + + # -2 cause the subtest adds to the stack + my $format = test2_stack()->[-2]->format; + my $handles = $format->handles or return; + for my $hn (0 .. @$handles) { + my $h = $handles->[$hn] || next; + my $layers = { map {$_ => 1} PerlIO::get_layers($h) }; + ok($layers->{utf8}, "utf8 is on for formatter handle $hn"); + } +}; + +subtest "rename imports" => sub { + package A::Consumer; + use Test2::V0 ':DEFAULT', '!subtest', subtest => {-as => 'a_subtest'}; + imported_ok('a_subtest'); + not_imported_ok('subtest'); +}; + +subtest "no meta" => sub { + package B::Consumer; + use Test2::V0 '!meta'; + imported_ok('meta_check'); + not_imported_ok('meta'); +}; + +done_testing; + +1; diff --git a/cpan/Test2-Suite/t/modules/Workflow.t b/cpan/Test2-Suite/t/modules/Workflow.t new file mode 100644 index 000000000000..b60649d68d02 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Workflow.t @@ -0,0 +1,3 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow'; + +skip_all "Tests not yet written"; diff --git a/cpan/Test2-Suite/t/modules/Workflow/BlockBase.t b/cpan/Test2-Suite/t/modules/Workflow/BlockBase.t new file mode 100644 index 000000000000..9d32f9f10c6e --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Workflow/BlockBase.t @@ -0,0 +1,3 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow::BlockBase'; + +skip_all "Tests not yet written"; diff --git a/cpan/Test2-Suite/t/modules/Workflow/Build.t b/cpan/Test2-Suite/t/modules/Workflow/Build.t new file mode 100644 index 000000000000..25cddd565543 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Workflow/Build.t @@ -0,0 +1,3 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow::Build'; + +skip_all "Tests not yet written"; diff --git a/cpan/Test2-Suite/t/modules/Workflow/Runner.t b/cpan/Test2-Suite/t/modules/Workflow/Runner.t new file mode 100644 index 000000000000..6348a31b98a5 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Workflow/Runner.t @@ -0,0 +1,3 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow::Runner'; + +skip_all "Tests not yet written"; diff --git a/cpan/Test2-Suite/t/modules/Workflow/Task.t b/cpan/Test2-Suite/t/modules/Workflow/Task.t new file mode 100644 index 000000000000..cca56d3860b9 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Workflow/Task.t @@ -0,0 +1,4 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow::Task'; + +skip_all "Tests not yet written"; + diff --git a/cpan/Test2-Suite/t/modules/Workflow/Task/Action.t b/cpan/Test2-Suite/t/modules/Workflow/Task/Action.t new file mode 100644 index 000000000000..d7193e9699a6 --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Workflow/Task/Action.t @@ -0,0 +1,5 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow::Task::Action'; + +can_ok($CLASS, 'around'); + +done_testing; diff --git a/cpan/Test2-Suite/t/modules/Workflow/Task/Group.t b/cpan/Test2-Suite/t/modules/Workflow/Task/Group.t new file mode 100644 index 000000000000..e1bca1cb5a3c --- /dev/null +++ b/cpan/Test2-Suite/t/modules/Workflow/Task/Group.t @@ -0,0 +1,7 @@ +use Test2::Bundle::Extended -target => 'Test2::Workflow::Task::Group'; + +skip_all "Tests not yet written"; + +can_ok($CLASS, qw/before after primary rand variant/); + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/10-set_and_dne.t b/cpan/Test2-Suite/t/regression/10-set_and_dne.t new file mode 100644 index 000000000000..5ba0cc64ad24 --- /dev/null +++ b/cpan/Test2-Suite/t/regression/10-set_and_dne.t @@ -0,0 +1,28 @@ +use Test2::Bundle::Extended; + +my $check = hash { + field first => 42; + field second => undef; + field third => DNE(); + field fourth => in_set(42, undef); + field fifth => in_set(42, undef); + field sixth => in_set(42, DNE()); + field seventh => in_set(42, DNE()); + field eighth => not_in_set(DNE()); +}; + +is( + { + first => 42, + second => undef, + # third DNE + fourth => 42, + fifth => undef, + sixth => 42, + # seventh DNE + eighth => 42, + }, + $check +); + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/132-bool.t b/cpan/Test2-Suite/t/regression/132-bool.t new file mode 100644 index 000000000000..3f6c34b7f2be --- /dev/null +++ b/cpan/Test2-Suite/t/regression/132-bool.t @@ -0,0 +1,57 @@ +use Test2::Require::AuthorTesting; +use Test2::Require::Perl 'v5.20'; +use Test2::V0; +use Test2::Plugin::BailOnFail; + +opendir(my $dh, 'lib/Test2/Compare/') or die "Could not open compare lib dir: $!"; + +for my $file (readdir($dh)) { + next unless $file =~ m/.pm$/; + next if $file eq 'Delta.pm'; + + require "Test2/Compare/$file"; + my $name = $file; + $name =~ s/\.pm$//g; + my $mod = "Test2::Compare::$name"; + + my $test = "./t/modules/Compare/$name.t"; + next unless -f $test; + + eval <<" EOT" or die $@; + package $mod; + + require Test2::Tools::Basic; + require Carp; + + use overload bool => sub { Carp::confess( 'illegal use of overloaded bool') } ; + use overload '""' => sub { \$_[0] }; + + my \$err; + main::subtest($name => sub { + package Test::$mod; + local \$@; + + main::like( + main::dies(sub { if(bless({}, "$mod")) { die "oops" }}), + qr/illegal use of overloaded bool/, + "Override for $mod is in place", + ); + + do "$test"; + \$err = \$@; + 1; + }); + + eval <<" ETT" or die $@; + no overload 'bool'; + no overload '""'; + 1; + ETT + + die \$err if \$err; + + 1; + EOT +} + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/247_check_ref_bool.t b/cpan/Test2-Suite/t/regression/247_check_ref_bool.t new file mode 100644 index 000000000000..b2689c9bc011 --- /dev/null +++ b/cpan/Test2-Suite/t/regression/247_check_ref_bool.t @@ -0,0 +1,34 @@ +use Test2::V0; + +BEGIN { + skip_all "Need JSON::MaybeXS: $@" unless eval { + require JSON::MaybeXS; + JSON::MaybeXS->import(qw/decode_json/); + 1; + }; +} + +my $data = '{ "aaa": true, "bbb": false }'; +my $h = decode_json($data); + +ok($h->{aaa}, "true"); +ok(!$h->{bbb}, "false"); +is($h->{aaa}, T(), 'Test true on true'); +is($h->{bbb}, F(), 'Test false on false'); +is($h, hash {aaa => T(), etc}, 'Test true on true'); +is($h, hash {bbb => F(), etc}, 'Test false on false'); + +my $events = intercept { + ok(!$h->{aaa}, "true"); + ok($h->{bbb}, "false"); + is($h, hash {field aaa => F(); etc}, 'Test false on true'); + is($h, hash {field bbb => T(); etc}, 'Test true on false'); +}; + +is( + [map { $_->causes_fail ? 1 : 0 } grep { $_->facet_data->{assert} } @$events], + [1, 1, 1, 1], + "All 4 events cause failure" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/27-1-Test2-Bundle-More.t b/cpan/Test2-Suite/t/regression/27-1-Test2-Bundle-More.t new file mode 100644 index 000000000000..a6fffef36259 --- /dev/null +++ b/cpan/Test2-Suite/t/regression/27-1-Test2-Bundle-More.t @@ -0,0 +1,7 @@ +use Test2::Bundle::More; +use strict; +use warnings; + +is_deeply({a => [1]}, {a => [1]}, "is_deeply() works, stuff is loaded"); + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/27-2-Test2-Tools-Compare.t b/cpan/Test2-Suite/t/regression/27-2-Test2-Tools-Compare.t new file mode 100644 index 000000000000..6ca18001ab7a --- /dev/null +++ b/cpan/Test2-Suite/t/regression/27-2-Test2-Tools-Compare.t @@ -0,0 +1,8 @@ +use Test2::Tools::Compare; +use strict; +use warnings; + +is({a => [1]}, {a => [1]}, "is() works, stuff is loaded"); + +require Test2::Tools::Basic; +Test2::Tools::Basic::done_testing(); diff --git a/cpan/Test2-Suite/t/regression/27-3-Test2-Tools-ClassicCompare.t b/cpan/Test2-Suite/t/regression/27-3-Test2-Tools-ClassicCompare.t new file mode 100644 index 000000000000..96c8e18b0f65 --- /dev/null +++ b/cpan/Test2-Suite/t/regression/27-3-Test2-Tools-ClassicCompare.t @@ -0,0 +1,8 @@ +use Test2::Tools::ClassicCompare; +use strict; +use warnings; + +is_deeply({a => [1]}, {a => [1]}, "is_deeply() works, stuff is loaded"); + +require Test2::Tools::Basic; +Test2::Tools::Basic::done_testing(); diff --git a/cpan/Test2-Suite/t/regression/43-bag-on-empty.t b/cpan/Test2-Suite/t/regression/43-bag-on-empty.t new file mode 100644 index 000000000000..34902a59e0cd --- /dev/null +++ b/cpan/Test2-Suite/t/regression/43-bag-on-empty.t @@ -0,0 +1,21 @@ +use Test2::Bundle::Extended; + +my $got = intercept { + my $check = bag { + item 'a'; + item 'b'; + end(); # Ensure no other elements exist. + }; + + is([], $check, 'All of the elements from bag found!'); # passes but shouldn't +}; + +like( + $got, + array { + event Fail => sub {}; + }, + "Bag check on empty array" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/Test2-Mock.t b/cpan/Test2-Suite/t/regression/Test2-Mock.t new file mode 100644 index 000000000000..a8c8caa50dfa --- /dev/null +++ b/cpan/Test2-Suite/t/regression/Test2-Mock.t @@ -0,0 +1,45 @@ +use Test2::Bundle::Extended; +use Test2::Mock; + +my $mock; + +ok( lives { + $mock = Test2::Mock->new( + class => 'Fake', + add => [ + foo => 'string', + bar => undef, + ], + ); + }, + 'Did not die when adding plain value' +); + +isa_ok( + $mock, + 'Test2::Mock' +); + +is( Fake::foo(), + 'string', + 'Correct value returned for add when plain string given' +); + +is( Fake::bar(), + undef, + 'Correct value returned for add when undef given' +); + +$mock->override(foo => undef, bar => 'string'); + +is( Fake::foo(), + undef, + 'Correct value returned for override when undef given' +); + +is( Fake::bar(), + 'string', + 'Correct value returned for override when plain string given' +); + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/Test2-Tools-Class.t b/cpan/Test2-Suite/t/regression/Test2-Tools-Class.t new file mode 100644 index 000000000000..8314758f9ce3 --- /dev/null +++ b/cpan/Test2-Suite/t/regression/Test2-Tools-Class.t @@ -0,0 +1,17 @@ +use Test2::Tools::Class; +use strict; +use warnings; + +{ + package My::Object; + use overload 'bool' => sub {$_[0]->{value}} +} + +my $true_value = bless {value => 1}, 'My::Object'; +my $false_value = bless {value => 0}, 'My::Object'; + +isa_ok($true_value, ['My::Object'], 'isa_ok when object overloads to true'); +isa_ok($false_value, ['My::Object'], 'isa_ok when object overloads to false'); + +require Test2::Tools::Basic; +Test2::Tools::Basic::done_testing(); diff --git a/cpan/Test2-Suite/t/regression/async_subtest_missing_parent.t b/cpan/Test2-Suite/t/regression/async_subtest_missing_parent.t new file mode 100644 index 000000000000..319b95984078 --- /dev/null +++ b/cpan/Test2-Suite/t/regression/async_subtest_missing_parent.t @@ -0,0 +1,24 @@ +use Test2::V0; +use Test2::Tools::AsyncSubtest; + +my $err; +my $events = intercept { + my $ast; + + subtest outer => sub { + plan 2; + ok(1); + $ast = async_subtest 'foo'; + $ast->run(sub { ok(1, 'pass') }); + }; + + $err = dies { $ast->finish }; +}; + +like( + $err, + qr/Attempt to close AsyncSubtest when original parent hub \(a non async-subtest\?\) has ended/, + "Throw an error when a subtest finishes without a parent" +); + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/todo_and_facets.t b/cpan/Test2-Suite/t/regression/todo_and_facets.t new file mode 100644 index 000000000000..c967f035005c --- /dev/null +++ b/cpan/Test2-Suite/t/regression/todo_and_facets.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test2::API qw/context/; + +use Test::More(); +use Test2::Tools::Basic qw/todo done_testing/; + +BEGIN { + *tm_ok = \&Test::More::ok; + *tm_pass = \&Test::More::pass; + *tm_fail = \&Test::More::fail; + + *bas_ok = \&Test2::Tools::Basic::ok; +} + +use vars qw/$TODO/; + +sub leg_ok($;$@) { + my ($bool, $name, @diag); + my $ctx = context(); + $ctx->ok($bool, $name, \@diag); + $ctx->release; + + return $bool; +} + +sub new_ok($;$@) { + my ($bool, $name, @diag) = @_; + my $ctx = context(); + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); +} + +{ + local $TODO = "Testing TODO"; + + tm_ok(0, "tm_ok fail"); + tm_fail('tm_fail'); + + leg_ok(0, "legacy ok fail"); + new_ok(0, "new ok fail"); + + bas_ok(0, "basic ok fail"); +} + +todo new_todo_test => sub { + tm_ok(0, "tm_ok fail"); + tm_fail('tm_fail'); + + leg_ok(0, "legacy ok fail"); + new_ok(0, "new ok fail"); + + bas_ok(0, "basic ok fail"); +}; + +done_testing; diff --git a/cpan/Test2-Suite/t/regression/utf8-mock.t b/cpan/Test2-Suite/t/regression/utf8-mock.t new file mode 100644 index 000000000000..762a67d0d063 --- /dev/null +++ b/cpan/Test2-Suite/t/regression/utf8-mock.t @@ -0,0 +1,23 @@ +use Test2::Plugin::UTF8; +use Test2::Bundle::More; +use Test2::Mock; +use Test2::Require::Module 'ExtUtils::MakeMaker'; +use ExtUtils::MakeMaker; + +ok 1; + +my $mock = Test2::Mock->new( + class => 'ExtUtils::MakeMaker', +); + +subtest 'user says yes' => sub { + + my($msg, $def); + + $mock->override(prompt => sub ($;$) { ($msg,$def) = @_; return 'y' }); + + ok 1; + +}; + +done_testing; diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index b749a4aec7d7..1bd05707cef5 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -1,4 +1,4 @@ -# This file is the data file for porting/podcheck.t. +# This file is the data file for t/porting/podcheck.t. # There are three types of lines. # Comment lines are white-space only or begin with a '#', like this one. Any # changes you make to the comment lines will be lost when the file is @@ -161,6 +161,7 @@ HTML::StripScripts HTTP::Lite iconv(1) iconv(3) +Importer indirect inetd(8) invoker @@ -291,6 +292,7 @@ Role::Tiny RPerl s2p Scalar::Readonly +Scope::Guard Scope::Upper sdbm(3) select(2)