Test-Simple-1.302210000755001750001750 014772042322 14434 5ustar00exodistexodist000000000000README100644001750001750 1432714772042322 15424 0ustar00exodistexodist000000000000Test-Simple-1.302210NAME Test2 - Framework for writing test tools that all work together. DESCRIPTION Test2 is a new testing framework produced by forking Test::Builder, completely refactoring it, adding many new features and capabilities. WHAT IS NEW? Easier to test new testing tools. From the beginning Test2 was built with introspection capabilities. With Test::Builder it was difficult at best to capture test tool output for verification. Test2 Makes it easy with Test2::API::intercept(). Better diagnostics capabilities. Test2 uses an Test2::API::Context object to track filename, line number, and tool details. This object greatly simplifies tracking for where errors should be reported. Event driven. Test2 based tools produce events which get passed through a processing system before being output by a formatter. This event system allows for rich plugin and extension support. More complete API. Test::Builder only provided a handful of methods for generating lines of TAP. Test2 took inventory of everything people were doing with Test::Builder that required hacking it up. Test2 made public API functions for nearly all the desired functionality people didn't previously have. Support for output other than TAP. Test::Builder assumed everything would end up as TAP. Test2 makes no such assumption. Test2 provides ways for you to specify alternative and custom formatters. Subtest implementation is more sane. The Test::Builder implementation of subtests was certifiably insane. Test2 uses a stacked event hub system that greatly improves how subtests are implemented. Support for threading/forking. Test2 support for forking and threading can be turned on using Test2::IPC. Once turned on threading and forking operate sanely and work as one would expect. GETTING STARTED If you are interested in writing tests using new tools then you should look at Test2::Suite. Test2::Suite is a separate cpan distribution that contains many tools implemented on Test2. If you are interested in writing new tools you should take a look at Test2::API first. NAMESPACE LAYOUT This describes the namespace layout for the Test2 ecosystem. Not all the namespaces listed here are part of the Test2 distribution, some are implemented in Test2::Suite. Test2::Tools:: This namespace is for sets of tools. Modules in this namespace should export tools like ok() and is(). Most things written for Test2 should go here. Modules in this namespace MUST NOT export subs from other tools. See the "Test2::Bundle::" namespace if you want to do that. Test2::Plugin:: This namespace is for plugins. Plugins are modules that change or enhance the behavior of Test2. An example of a plugin is a module that sets the encoding to utf8 globally. Another example is a module that causes a bail-out event after the first test failure. Test2::Bundle:: This namespace is for bundles of tools and plugins. Loading one of these may load multiple tools and plugins. Modules in this namespace should not implement tools directly. In general modules in this namespace should load tools and plugins, then re-export things into the consumers namespace. Test2::Require:: This namespace is for modules that cause a test to be skipped when conditions do not allow it to run. Examples would be modules that skip the test on older perls, or when non-essential modules have not been installed. Test2::Formatter:: Formatters live under this namespace. Test2::Formatter::TAP is the only formatter currently. It is acceptable for third party distributions to create new formatters under this namespace. Test2::Event:: Events live under this namespace. It is considered acceptable for third party distributions to add new event types in this namespace. Test2::Hub:: Hub subclasses (and some hub utility objects) live under this namespace. It is perfectly reasonable for third party distributions to add new hub subclasses in this namespace. Test2::IPC:: The IPC subsystem lives in this namespace. There are not many good reasons to add anything to this namespace, with exception of IPC drivers. Test2::IPC::Driver:: IPC drivers live in this namespace. It is fine to create new IPC drivers and to put them in this namespace. Test2::Util:: This namespace is for general utilities used by testing tools. Please be considerate when adding new modules to this namespace. Test2::API:: This is for Test2 API and related packages. Test2:: The Test2:: namespace is intended for extensions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extensions that are used to build tools and plugins may go here. In short: If the module exports anything that should be run directly by a test script it should probably NOT go directly into Test2::XXX. SEE ALSO Test2::API - Primary API functions. Test2::API::Context - Detailed documentation of the context object. Test2::IPC - The IPC system used for threading/fork support. Test2::Formatter - Formatters such as TAP live here. Test2::Event - Events live in this namespace. Test2::Hub - All events eventually funnel through a hub. Custom hubs are how intercept() and run_subtest() are implemented. CONTACTING US Many Test2 developers and users lurk on irc://irc.perl.org/#perl-qa and irc://irc.perl.org/#toolchain. We also have a slack team that can be joined by anyone with an @cpan.org email address https://perl-test2.slack.com/ If you do not have an @cpan.org email you can ask for a slack invite by emailing Chad Granum . SOURCE The source code repository for Test2 can be found at https://github.com/Test-More/test-more/. MAINTAINERS Chad Granum AUTHORS Chad Granum COPYRIGHT Copyright Chad Granum . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See https://dev.perl.org/licenses/ LICENSE100644001750001750 4642414772042322 15554 0ustar00exodistexodist000000000000Test-Simple-1.302210This software is copyright (c) 2025 by Chad Granum. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2025 by Chad Granum. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Perl Artistic License 1.0 --- This software is Copyright (c) 2025 by Chad Granum. This is free software, licensed under: The Perl Artistic License 1.0 The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Changes100644001750001750 34624514772042322 16066 0ustar00exodistexodist000000000000Test-Simple-1.302210******************************************************************************* * Please note, over time several distributions have been merged into this one * * over time. Changes file history has also been merged, so entries for these * * merged distributions can be found further down in the file. * ******************************************************************************* 1.302210 2025-03-29 12:06:57-07:00 America/Los_Angeles - Alexander Hartmaier - fix typo in Test2::Util::Trace docs - Karen Etheridge - documentation fixes throughout for affect vs effect - Yasuharu Iida feat - Test2::Tools::Warnings warns called in void context - bernhard Eliminate - Remove unnecessary empty list assignments - Graham Knop calculate - CAN_SIGSYS when called rather than as a constant 1.302209 2025-01-22 08:17:20-08:00 America/Los_Angeles - #1021 don't use base (Thanks Haarg) - #1022 use PerlIO::get_layers without loading PerlIO.pm (Thanks Haarg) - #1023 move try_sig_mask to separate file to avoid always loading POSIX (Thanks Haarg) 1.302208 2025-01-21 10:19:33-08:00 America/Los_Angeles - avoid closing over values in string eval when comparing values #1018 (Thanks Haarg) 1.302207 2024-12-27 18:13:18-08:00 America/Los_Angeles - Fix debugging info when JSON::MaybeXS is missing (Thanks James E Keenan) - Fix typos (Thanks sobrado8086) - Add TEST2_ENABLE_PLUGINS env var - Add Test2::Env docs 1.302206 2024-12-19 17:51:07-08:00 America/Los_Angeles - Remove Test::Builder::IO::Scalar - Fix #1016 1.302205 2024-12-19 09:28:05-08:00 America/Los_Angeles - Use our instead of 'use vars' - Fix $[ usage - Doc updates 1.302204 2024-09-14 10:32:25-07:00 America/Los_Angeles - Add pending diagnostics functionality - Show warnings/exceptions for no_warnings() and lives() 1.302203 2024-09-04 16:15:07-07:00 America/Los_Angeles - Fix some tests when run on windows 1.302202 2024-09-02 16:27:17-07:00 America/Los_Angeles - Add comment on how to make tables bigger, #931 - Typo fix 1.302201 2024-08-13 08:19:01-07:00 America/Los_Angeles - Fix bug found by new warnings in blead (Thanks Mauke) 1.302200 2024-08-04 11:22:17-07:00 America/Los_Angeles - Merge Test2-Suite into Test-Simple - Some doc updates - Some test fixes 1.302199 2024-04-25 15:05:00+01:00 Europe/Lisbon - Minor fixes 1.302198 2023-11-30 10:07:14-08:00 America/Los_Angeles - Remove use of defined-or operator 1.302197 2023-11-28 17:30:37-08:00 America/Los_Angeles - Add ability to attach timestamps to trace objects via api or env var 1.302196 2023-10-24 10:27:33-07:00 America/Los_Angeles - Fix #882 - Fix handling of VSTRING and LVALUE refs in is_deeply() #918 - Merge several doc fixes from mauke 1.302195 2023-04-28 05:55:54-07:00 America/Los_Angeles - Fix done_testing(0) producing 2 plans and an incorrect message 1.302194 2023-03-13 20:06:57-07:00 America/Los_Angeles - Fix failing test on 5.10 1.302193 2023-03-06 09:38:00-08:00 America/Los_Angeles - Deprecate isn't() 1.302192 2023-02-02 07:34:08-08:00 America/Los_Angeles - Silence deprecation warning when testing smartmatch 1.302191 2022-07-09 10:48:09-07:00 America/Los_Angeles - CI Fixes - avoid failing when printing diagnostic info comparing partial overload objects 1.302190 2022-03-04 15:07:45-08:00 America/Los_Angeles - Fix subtest times to be hi-res 1.302189 2022-02-24 21:23:05-08:00 America/Los_Angeles - Fix #890, #891 1.302188 2021-09-29 08:31:27-07:00 America/Los_Angeles - Fix for non-gcc compilers on 5.10.0 1.302187 2021-09-17 06:59:05-07:00 America/Los_Angeles - Fix tests for core boolean support 1.302186 2021-07-26 10:37:46-07:00 America/Los_Angeles - Add start/stop timestamps to subtests 1.302185 2021-05-19 11:08:39-07:00 America/Los_Angeles - Fix test from last commit to pass on older perls 1.302184 2021-05-19 09:19:08-07:00 America/Los_Angeles - Fix Test::Builder->skip to stringify arguments 1.302183 2020-10-21 20:10:36-07:00 America/Los_Angeles - avoid closing over scalar in BEGIN block in cmp_ok eval 1.302182 2020-10-05 22:02:28-07:00 America/Los_Angeles - Fix 5.6 support - Fix fragile %INC handling in a test 1.302181 2020-09-14 09:46:04-07:00 America/Los_Angeles - put try_sig_mask back where it goes (And add test to prevent this in the future) - Drop new List::Util requirement back down 1.302180 2020-09-13 23:11:18-07:00 America/Los_Angeles - No changes since last trial 1.302179 2020-09-12 22:35:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum List::Util version (for uniq) 1.302178 2020-09-07 14:11:52-07:00 America/Los_Angeles (TRIAL RELEASE) - Move try_sig_mask to the only module that uses it. - Inherit warnings bitmask in cmp_ok string eval - Update copyright date - Improved API for interept {} and what it returns 1.302177 2020-08-06 21:46:06-07:00 America/Los_Angeles - Minor fix to author downstream test - No significant changes since the last trial 1.302176 2020-08-05 21:45:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix Test::More's $TODO inside intercept (#862) 1.302175 2020-04-13 11:37:36-07:00 America/Los_Angeles - Fix typos in POD - Fix incorrect Test2::Hub documentation - Fix test that needed . in @INC on windows - Fix Breakage test to show more info 1.302174 2020-03-30 13:55:54-07:00 America/Los_Angeles - Fallback if JSON::PP is not available during IPC errors 1.302173 2020-03-27 09:00:16-07:00 America/Los_Angeles - Add extra debugging for "Not all files from hub '...' have been collected!" 1.302172 2020-03-08 15:21:25-07:00 America/Los_Angeles - Fix transition doc - Fix warnings from info / debug tap 1.302171 2020-01-17 09:47:59-08:00 America/Los_Angeles - Fix 5.6 - Fix EBDIC - Upgrade Object::HashBase - Clarify error message in test (#841) - Spelling/Grammer fixes 1.302170 2019-12-02 13:25:48-08:00 America/Los_Angeles - Fix unwanted END phase event (#840) 1.302169 2019-11-18 15:49:38-08:00 America/Los_Angeles - Update inline Object::HashBase - Avoid 'used only once' warnings in BEGIN and END blocks (James E Keenan ) 1.302168 2019-09-06 07:40:18-07:00 America/Los_Angeles - Fix Typo in a Test2::API::Breakage warning (Thanks E. Choroba) - Delay loading of Term::Table until needed (Thanks Graham Knop) 1.302167 2019-08-23 14:07:58-07:00 America/Los_Angeles - add test2_is_testing_done api method - Fix string compare warning 1.302166 2019-08-15 10:37:01-07:00 America/Los_Angeles - Fix context test on older perls 1.302165 2019-08-15 10:21:09-07:00 America/Los_Angeles - Better diagnostics when a context is destroyed unexpectedly - Add an event to notify when END phase starts 1.302164 2019-04-27 01:43:44-07:00 America/Los_Angeles - No changes since trial 1.302163 2019-04-25 05:45:47-07:00 America/Los_Angeles (TRIAL RELEASE) - Do not use threads::Shared in Test::Tester::Capture (#826) - Add missing version info to Info/Table - Fix event in global destruction bug (#827) - Proper fix for todo = '' (#812, #829) 1.302162 2019-02-05 19:55:14-08:00 America/Los_Angeles - Typo fixes in documentation 1.302161 2019-01-29 09:34:27-08:00 America/Los_Angeles (TRIAL RELEASE) - Remove SHM Optimization 1.302160 2019-01-18 11:44:33-08:00 America/Los_Angeles - No Changes since last trial release 1.302159 2019-01-09 13:21:37-08:00 America/Los_Angeles (TRIAL RELEASE) - Add table support to ctx->fail and ctx->fail_and_return - Fix Instance.t on haiku-os 1.302158 2019-01-08 15:36:24-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix TAP test on windows - Fix math errors in table indentation - Devel requires Term::Table 1.302157 2019-01-08 14:10:29-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix minor typos and missing doc sections - Add table support in info facet and TAP formatter 1.302156 2019-01-07 11:13:07-08:00 America/Los_Angeles - No changes from last trial 1.302155 2019-01-04 11:25:17-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix test not to fail in non-english locales 1.302154 2019-01-04 10:20:54-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix SHM pid checking for some platforms in Instance.t - Add SHM errno/msg to warning about SHM going away 1.302153 2019-01-03 08:39:42-08:00 America/Los_Angeles (TRIAL RELEASE) - Improve SHM verification and state awareness 1.302152 2018-12-26 12:21:32-08:00 America/Los_Angeles (TRIAL RELEASE) - More Instance.t improvements - Add trace to SHM error when possible 1.302151 2018-12-20 11:05:47-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix another locale error in Instance.t 1.302150 2018-12-20 10:57:09-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix locale error in Instance.t - Windows test fixes - perl 5.6 test fixes 1.302149 2018-12-20 09:47:31-08:00 America/Los_Angeles (TRIAL RELEASE) - Even more SHM error improvements 1.302148 2018-12-17 13:08:23-08:00 America/Los_Angeles (TRIAL RELEASE) - Further Improve SHM error message 1.302147 2018-12-17 12:59:14-08:00 America/Los_Angeles (TRIAL RELEASE) - Improve SHM error message 1.302146 2018-12-17 09:06:44-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix SHM test to work on machines without SHM 1.302145 2018-12-12 11:26:32-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix localization error in new test (#820) 1.302144 2018-12-12 09:51:25-08:00 America/Los_Angeles (TRIAL RELEASE) - Add tests for shmwrite fix (#815) 1.302143 2018-12-11 19:10:37-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix failure to check error code on shmwrite (#815) 1.302142 2018-12-11 11:55:22-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix #814 Windows fork+test failure - Fix #819 Documentation updates - Fix #810 Verbose TAP newline regression - Fix #817 local $TODO bug - Fix #812 Another local $TODO bug - Fix #815 shm read warning - Merge doc fix PR's from magnolia-k (thanks!) 1.302141 2018-11-30 14:27:19-08:00 America/Los_Angeles - Fix bug where IPC init failed in preload+fork environments 1.302140 2018-08-13 08:00:25-07:00 America/Los_Angeles - No Changes since last release 1.302139 2018-07-17 12:38:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Mask warning from the recent IPC fix generated when threaded Test tools are loaded at run-time 1.302138 2018-07-11 09:29:51-07:00 America/Los_Angeles - No changes since trial 1.302137 2018-05-25 08:45:13-07:00 America/Los_Angeles (TRIAL RELEASE) - Make it safe to fork before events in IPC 1.302136 2018-04-19 05:40:11-07:00 America/Los_Angeles - Add test2_add_callback_testing_done to Test2::API 1.302135 2018-03-29 22:53:00-07:00 America/Los_Angeles - No changes since last trial 1.302134 2018-03-19 21:20:08-07:00 America/Los_Angeles (TRIAL RELEASE) - Make sure all hubs, events, and contexts get a unique (per run) id. - Use a common generator for unique(enough) id's (not UUIDs) 1.302133 2018-03-11 12:48:37-07:00 America/Los_Angeles - No changes since last trial 1.302132 2018-03-09 15:43:51-08:00 America/Los_Angeles (TRIAL RELEASE) - Add method to validate facet data - Add Test2::Event::V2 event class, and context helpers - Improve how events handle facets - Break out meta_facet_data - Document and fix Facets2Legacy - Fix nested and in_subtest to look at hub facets - Fix event->related and trace with uuid 1.302131 2018-03-07 09:36:16-08:00 America/Los_Angeles (TRIAL RELEASE) - Make sure event puts the uuid into the about facet 1.302130 2018-03-07 08:07:54-08:00 America/Los_Angeles - No changes since last trial 1.302129 2018-03-06 13:43:22-08:00 America/Los_Angeles (TRIAL RELEASE) - Make hubs tag events with a new facet 1.302128 2018-03-05 09:26:53-08:00 America/Los_Angeles - No changes since the trial 1.302127 2018-03-02 12:43:56-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix missing UUID in Test::Builder subtests 1.302126 2018-03-01 23:15:52-08:00 America/Los_Angeles (TRIAL RELEASE) - Add optional UUID tagging 1.302125 2018-02-21 23:10:39-08:00 America/Los_Angeles - No changes since trial 1.302124 2018-02-13 22:02:48-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix a test to skip without threads 1.302123 2018-02-13 21:39:31-08:00 America/Los_Angeles (TRIAL RELEASE) - Make it possible to disable IPC 1.302122 2018-02-05 08:13:56-08:00 America/Los_Angeles - Add 'mode' ro render facet 1.302121 2018-02-04 13:27:41-08:00 America/Los_Angeles - Update Copyright - Add 'render' facet 1.302120 2017-11-29 18:49:15-08:00 America/Los_Angeles - No Changes since last trial 1.302119 2017-11-28 15:35:42-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix IPC reload bug 1.302118 2017-11-28 10:14:12-08:00 America/Los_Angeles - No Changes since last trial 1.302117 2017-11-27 14:10:53-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix event Out of Order bug - Add driver_abort() hook for IPC Drivers 1.302116 2017-11-23 15:14:26-08:00 America/Los_Angeles (TRIAL RELEASE) - add better interface for ipc_wait 1.302115 2017-11-22 21:14:55-08:00 America/Los_Angeles (TRIAL RELEASE) - ipc_wait now reports exit and signal values 1.302114 2017-11-21 15:28:39-08:00 America/Los_Angeles (TRIAL RELEASE) - Added pre-subtest hook to Test2::API (#801 from dakkar) 1.302113 2017-11-20 14:04:16-08:00 America/Los_Angeles - Fix SIGPIPE in IPC test - Mark a test as usually AUTHOR_TESTING only 1.302112 2017-11-20 06:43:16-08:00 America/Los_Angeles - Fix test on threaded 5.8 1.302111 2017-11-18 09:54:33-08:00 America/Los_Angeles - Remove debugging from previous trial 1.302110 2017-11-17 09:47:23-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix test breakage (from previous trial) on older perls 1.302109 2017-11-17 09:35:48-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix some fragile tests - Add debugging to API/Instance.t for a cpan-testers failure 1.302108 2017-11-16 14:19:24-08:00 America/Los_Angeles (TRIAL RELEASE) - Apply p5p test patch from Craig A. Berry 1.302107 2017-11-16 07:44:59-08:00 America/Los_Angeles (TRIAL RELEASE) - Allow regexp in Test::Tester 1.302106 2017-10-20 20:42:43-07:00 America/Los_Angeles - Make version number in HashBase sane. 1.302105 2017-10-20 07:09:45-07:00 America/Los_Angeles - No changes since last trial 1.302104 2017-10-19 11:39:01-07:00 America/Los_Angeles (TRIAL RELEASE) - Combine multiple diags into one event 1.302103 2017-10-15 10:11:29-07:00 America/Los_Angeles - No changes since last TRIAL 1.302102 2017-10-14 20:05:45-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix some TODO edge cases that were not previously accounted for 1.302101 2017-10-12 07:43:16-07:00 America/Los_Angeles - Bump Test::Builder::IO::Scalar version for core 1.302100 2017-10-10 14:30:18-07:00 America/Los_Angeles - No changes since last TRIAL 1.302099 2017-10-10 09:29:40-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix run_subtest inherit_trace option 1.302098 2017-10-03 06:13:49-07:00 America/Los_Angeles - Add docs for test2_stdout and test2_stderr - Fix 5.6 support 1.302097 2017-10-02 19:35:08-07:00 America/Los_Angeles - Fix hub->process bug that could let an error pass - Fix #789 (Modification of read only value) - Fix typo in Test::Builder when looking for IPC (#777) - Fix #791, clone_io broke on scalar io layer - Fix #790 and #756, Exception event stingify exception - Localize $^E in context (#780) - Fix test that failed in verbose mode (#770) 1.302096 2017-09-10 21:16:18-07:00 America/Los_Angeles - Fix to work with subref-in-stash optimisation (Father C.) 1.302095 2017-08-31 20:35:22-07:00 America/Los_Angeles (TRIAL RELEASE) - Make several tests work with preload 1.302094 2017-08-30 21:27:23-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix Test::Builder in a preload scenario 1.302093 2017-08-29 21:05:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Make sure Test::Builder does not initialize Test2 too soon. 1.302092 2017-08-28 21:30:06-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix bug in Facets for TodoDiag - Add API command to reset after a fork - Add 'important' flag to info event facet 1.302091 2017-08-08 19:50:55-07:00 America/Los_Angeles (TRIAL RELEASE) - Add 'new_root' constructor for formatters - Add intercept_deep() to the API - Fix bug in Version event - Add 'number' attribute to assertion facet 1.302090 2017-07-09 21:10:08-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix test that unintentionally required Test2::Suite 1.302089 2017-07-09 20:51:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix plan in buffered subtest so that the facts say it is buffered 1.302088 2017-06-28 21:55:21-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix tests on perl 5.25+ with newer Data::Dumper 1.302087 2017-06-26 20:32:21-07:00 America/Los_Angeles (TRIAL RELEASE) - Introduce 'Facets' for events - Performance enhancements - Upgrade inline HashBase - Move Test2::Util::Trace to Test2::EventFacet::Trace - Track hub id in Trace - Remove Info event - Add Pass and Fail events - Remove Event JSON interface 1.302086 2017-06-20 10:43:13-07:00 America/Los_Angeles - Make it possible to turn off result logging in Test::Builder 1.302085 2017-05-01 19:24:37-07:00 America/Los_Angeles - No Changes since last TRIAL 1.302084 2017-04-29 20:42:48-07:00 America/Los_Angeles (TRIAL RELEASE) - Better IO management - Allow access to the STDERR/STDOUT Test2::API uses - Formatters should use the Test2::API handles 1.302083 2017-04-14 10:55:26-07:00 America/Los_Angeles - Update some breakage info for Test::More::Prefix and Test::DBIx::Class::Schema 1.302082 2017-04-11 12:56:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix test that incorrectly called private function as method 1.302081 2017-04-06 10:39:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix threads timeout for older perls (as best we can) 1.302080 2017-04-04 20:24:55-07:00 America/Los_Angeles (TRIAL RELEASE) - Timeout when waiting for child procs and threads (#765) - Fix SIGSYS localization issue (#758) - Fix outdated docs (#759, #754) - Fix bail-out in buffered subtest (#747) 1.302079 2017-04-03 12:12:02-07:00 America/Los_Angeles (TRIAL RELEASE) - Fixes for '. in @INC' changes (#768) 1.302078 2017-03-01 15:24:12-08:00 America/Los_Angeles - No changes since last trial 1.302077 2017-02-19 14:34:30-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix #762, newlines for todo subtest - Revisit #637, fix rare race condition it created 1.302076 2017-02-01 19:38:42-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix crash when TB->reset used inside subtest 1.302075 2017-01-10 19:39:28-08:00 America/Los_Angeles - No changes, just marking a stable release 1.302074 2017-01-08 11:41:44-08:00 America/Los_Angeles (TRIAL RELEASE) - Add 'cid' to trace - Add signatures to trace - Add related() to events - Now it is possible to check if events are related - Add 'no_fork' option to run_subtest() 1.302073 2016-12-18 23:02:54-08:00 America/Los_Angeles - No changes from last trial 1.302072 2016-12-18 01:08:12-08:00 America/Los_Angeles (TRIAL RELEASE) - Expose tools.pl as Test2::Tools::Tiny 1.302071 2016-12-17 12:08:29-08:00 America/Los_Angeles - No changes since last trial release 1.302070 2016-12-14 21:32:47-08:00 America/Los_Angeles (TRIAL RELEASE) - Added two new event classes, Test2::Event::Encoding and Test2::Event::TAP::Version. These are primarily being added for the benefit of Test2::Harness now, but they could be useful for other Test2 event consumer tools in the future. Implemented by Dave Rolsky (#743). 1.302069 2016-12-12 15:03:04-08:00 America/Los_Angeles (TRIAL RELEASE) - Generate HashBase from Object::HashBase which has been split out - When a subtest is marked as todo, all of its contained Ok and Subtest events are now updated so that they return true for $e->effective_pass. Implemented by Dave Rolsky. (#742) 1.302068 2016-12-03 13:50:01-08:00 America/Los_Angeles (TRIAL RELEASE) - Add TO_JSON and from_json methods to Test2::Event and Test2::Trace::Util to faciliate transferring event data between processes. Implemented by Dave Rolsky. (#741). 1.302067 2016-11-23 07:37:56-08:00 America/Los_Angeles - Fix context test for recent blead. 1.302066 2016-11-08 07:58:39-08:00 America/Los_Angeles (TRIAL RELEASE) - Handle cases where SysV IPC can be available but not enabled - Import 'context' into Test2::IPC, it is used by 'cull' - Propogate warnings settings to use_ok (#736) 1.302065 2016-10-30 11:54:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Set the TEST_ACTIVE env var to true - Set the TEST2_ACTIVE env var to true - Fix the oldest bug still in the bug list (#6) This fixes cmp_ok output is some confusing cases - Update travis config - Add missing author deps - Fix handling of negative pid's on windows - Add can() to Test::Tester::Delegate (despite deprecation) - Fix some minor test issues 1.302064 2016-10-24 21:03:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Repo management improvements - Better handling of info vs diag in ->send_event - Fix test that used 'parent' - Better handling of non-bumping failures (#728) 1.302063 2016-10-23 21:31:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix double release when 'throw' is used in context_do() 1.302062 2016-10-20 06:16:08-07:00 America/Los_Angeles - No changes from last trial 1.302061 2016-09-30 14:49:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Removed a warning when using a non-TAP formatter with Test::Builder about the formatter not "no_header" and "no_diag". This happened even if the alternative formatter class implemented these attributes. - When finalize is called on a formatter, it now receives one more argument, a boolean indicating whether or not the call is for a subtest or not. 1.302060 2016-09-25 12:46:46-07:00 America/Los_Angeles (TRIAL RELEASE) - Formatters now have terminate() and finalize() methods. These are called when there is a skip_all or bail event (terminate) or when a test suite is exiting normally (finalize). This allows formatters to finalize their output, which is important for any sort of document-oriented format (as opposed to a stream format like TAP). (#723) 1.302059 2016-09-25 12:32:21-07:00 America/Los_Angeles - No changes from last trial 1.302058 2016-09-21 10:46:13-07:00 America/Los_Angeles (TRIAL RELEASE) - Mask warning when comparing $@ in Test2::API::Context 1.302057 2016-09-18 12:12:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Doc fixes - Win32 color support in Test::Builder::Tester - Support v-strings in is_deeply - A streamed subtest run inside a buffered subtest will be automatically converted to a buffered subtest. Otherwise the output from inside the subtest is lost entirely. (#721) 1.302056 2016-09-12 09:03:49-07:00 America/Los_Angeles - Minor typo fix - No logic chnges since last trial 1.302055 2016-08-30 12:13:32-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix special case of ok line ending in \ - Improve a test that captures STDERR/STDOUT (Thanks HAARG) 1.302054 2016-08-20 16:21:44-07:00 America/Los_Angeles (TRIAL RELEASE) - Allow '#' and '\n' in ok names 1.302053 2016-08-17 21:22:55-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix skip_all in require in intercept (#696) - Documentation of what is better in Test2 (#663) - Document Test::Builder::Tester plan limitations - Document limitations in is_deeply (#595) - Better documentation of done_testing purpose (#151) - Make ctx->send_event detect termination events (#707) 1.302052 2016-08-13 14:34:07-07:00 America/Los_Angeles - No Changes from last trial 1.302051 2016-08-11 20:26:22-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix setting hub when getting context 1.302050 2016-08-10 22:12:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Add contact info to main doc and readme 1.302049 2016-07-28 07:03:31-07:00 America/Los_Angeles - No Changes from last trial 1.302048 2016-07-27 07:42:14-07:00 America/Los_Angeles (TRIAL RELEASE) - Add 'active' attribute to hub 1.302047 2016-07-22 22:36:29-07:00 America/Los_Angeles - No Changes from last trial 1.302046 2016-07-19 06:58:43-07:00 America/Los_Angeles (TRIAL RELEASE) - Restore traditional note/diag return values (#694) 1.302045 2016-07-18 09:05:15-07:00 America/Los_Angeles - No changes from last TRIAL release 1.302044 2016-07-13 17:56:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix test that segv'd on older perls 1.302043 2016-07-12 09:37:31-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix TODO in mixed T2/TB subtests 1.302042 2016-07-11 20:30:35-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix IPC event ordering bug 1.302041 2016-07-09 17:01:45-07:00 America/Los_Angeles (TRIAL RELEASE) - Work around IPC bug on windows 1.302040 2016-07-09 16:55:00-07:00 America/Los_Angeles - No changes from last trial 1.302039 2016-07-07 22:01:02-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Info event for better diagnostics 1.302038 2016-07-05 07:00:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix broken MANIFEST.SKIP entries (#689) 1.302037 2016-07-04 10:09:00-07:00 America/Los_Angeles - No changes from trial 1.302036 2016-07-03 11:52:45-07:00 America/Los_Angeles (TRIAL RELEASE) - Restore PerlIO layer cloning on STDERR and STDOUT 1.302035 2016-06-27 08:55:55-07:00 America/Los_Angeles - No changes since TRIAL release 1.302034 2016-06-25 13:51:00-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix some breakage info (Thanks Dolman!) - POD Fixes (Thanks cpansprout!) 1.302033 2016-06-24 05:56:54-07:00 America/Los_Angeles - No changes from last trial release 1.302032 2016-06-22 11:30:46-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix nested TODO handling of Diags (#684) 1.302031 2016-06-21 09:51:27-07:00 America/Los_Angeles - Remove carp from dep list #682 1.302030 2016-06-18 19:02:55-07:00 America/Los_Angeles - No changes from last DEV release 1.302029 2016-06-17 06:56:54-07:00 America/Los_Angeles (TRIAL RELEASE) - Properly skip thread test when threads are broken 1.302028 2016-06-16 19:21:58-07:00 America/Los_Angeles (TRIAL RELEASE) - Add 'inherit_trace' param to run_subtest 1.302027 2016-06-15 09:42:32-07:00 America/Los_Angeles (TRIAL RELEASE) - use pre_filter instead of filter for TODO in Test::Builder (Fix $683) - Fix typos in transitions doc (#681) 1.302026 2016-06-07 07:53:30-07:00 America/Los_Angeles - No Changes from 1.302025-TRIAL 1.302025 2016-06-06 22:38:12-07:00 America/Los_Angeles (TRIAL RELEASE) - Make sure enabling culling/shm sets pid and tid (Fix #679) 1.302024 2016-06-02 20:27:35-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Generic event type 1.302023 2016-06-02 08:09:54-07:00 America/Los_Angeles (TRIAL RELEASE) - Do not fail if Test2::API::Breakage cannot load (rare 5.10.0 issue) - Potential fix for t/Legacy/Regression/637.t - Make t/Legacy/Regression/637.t AUTHOR_TESTING for now 1.302022 2016-05-28 17:53:11-07:00 America/Los_Angeles - Improve thread checks to better detect broken 5.10 builds - Use thread checks to skip/run t/Legacy/Regression/637.t 1.302021 2016-05-20 21:47:17-07:00 America/Los_Angeles (TRIAL RELEASE) - Files.t should warn, not die, if it cannot remove its temp dir. - VMS fixes for Files.t and IPC system 1.302020 2016-05-18 11:54:15-07:00 America/Los_Angeles (TRIAL RELEASE) - Many micro-opts from Graham Knop (haarg) - Spelling fixes and tests from Karen Etheridge (ether) - Fix leaky File.t file so that tmp doesn't fill up - Move some modules out of the known broken list in xt tests - Add Test2 based tools to downstream testing - Change when PID/TID are stashed (for forkprove) 1.302019 2016-05-18 08:16:39-07:00 America/Los_Angeles - POD Spelling fixes 1.302018 2016-05-14 09:08:05-07:00 America/Los_Angeles (TRIAL RELEASE) - Handle Test::Builder::Exception properly - Silence noisy STDERR in test suite 1.302017 2016-05-13 08:09:58-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix util.t win32 bug 1.302016 2016-05-12 19:43:38-07:00 America/Los_Angeles (TRIAL RELEASE) - Block signals in critical IPC section (Fix #661 and #668) - Merge Examples and examples into one dir (#660) - Documentation and typo fixes - Make Test2::Util::get_tid have a consistent prototype (#665) - Make TB->no_plan a no-op if a plan is set 1.302015 2016-05-09 07:46:54-07:00 America/Los_Angeles - Add Test::Alien to breakage info - Add Device::Chip to breakage info - Add subtest outdent to transition.pod 1.302014_010 2016-05-03 12:09:14-07:00 America/Los_Angeles (TRIAL RELEASE) - RC10 - Update x-breaks, Breakage.pm, and Transition.POD - Fix shared memory leak - Fix typos and clarify docs. 1.302014_009 2016-04-27 10:05:18-07:00 America/Los_Angeles (TRIAL RELEASE) - RC9 - No logic changes - Update x-breaks stuff - Update email addresses 1.302014_008 2016-04-26 11:40:40-07:00 America/Los_Angeles (TRIAL RELEASE) - RC8 - Fix bug when using defined, but empty (or space) as a test name in a subtest - Better notificatons for late Test::Builder load - Recommend Test2::Transition if you have outdated modules - Document Test::Builder::TodoDiag and Test::Builder::Formatter 1.302014_007 2016-04-24 13:09:03-07:00 America/Los_Angeles (TRIAL RELEASE) - RC7 - Fix #642 - Persistent environments need to have ENDING flag cleared 1.302014_006 2016-04-24 02:31:13-07:00 America/Los_Angeles (TRIAL RELEASE) - RC6 - Remove reduntant and problematic parts of 00-report.t - No changes to actual code, just a test that provides diags 1.302014_005 2016-04-24 01:55:55-07:00 America/Los_Angeles (TRIAL RELEASE) - RC5 - Prevent the breakage reporter from being a test failure - No changes to actual code, just a test that provides diags 1.302014_004 2016-04-23 16:21:34-07:00 America/Los_Angeles (TRIAL RELEASE) - RC4 - Update breakage info - Fix IPC files driver to use the most significant data in the shm (needs test) 1.302014_003 2016-04-23 03:20:36-07:00 America/Los_Angeles (TRIAL RELEASE) - RC3 - Localize $@ and $! when loading Data::Dumper in explain() 1.302014_002 2016-04-22 14:54:51-07:00 America/Los_Angeles (TRIAL RELEASE) - RC2 - Restore X-Breaks meta info - Keep dist.ini in the tarball 1.302014_001 2016-04-22 04:01:50-07:00 America/Los_Angeles (TRIAL RELEASE) - RC1 - Merge Test2 into the Test-Simple dist - Remove experimental status - Update copyright dates - Better error messages when using Carp in Hashbase init() - Document 2 methods on Events - Fix Test2 #17 (typo fix in docs) - Report version mismatches between Test::Builder and Test2 - Update transition docs - Breakage library and warnings ***************************************************************************** * * * BELOW THIS POINT ARE THE SEPERATE CHANGELOGS FOR Test-Simple, Test2, AND * * Test-Stream. * * * ***************************************************************************** Test-Simple 1.302013_019 2016-04-13 20:23:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Expand no_numbers support to custom formatters Test-Simple 1.302013_018 2016-04-07 21:23:03-07:00 America/Los_Angeles (TRIAL RELEASE) - Support Test2 using an alternative formatter Test-Simple 1.302013_017 2016-04-05 11:13:50-07:00 America/Los_Angeles (TRIAL RELEASE) - Support subtest identification for events - Bump minimum Test2 version Test-Simple 1.302013_016 2016-04-04 21:33:20-07:00 America/Los_Angeles (TRIAL RELEASE) - Support some newer event features from Test2 - Bump minimum Test2 version Test-Simple 1.302013_015 2016-03-29 09:24:10-07:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version to protect from segv Test-Simple 1.302013_014 2016-03-08 10:00:50-08:00 America/Los_Angeles (TRIAL RELEASE) - Skip test added in last release when threading is not avilable Test-Simple 1.302013_013 2016-03-08 09:19:39-08:00 America/Los_Angeles (TRIAL RELEASE) - Test::Builder->reset now resets hub's idea of root pid/tid (#637) Test-Simple 1.302013_012 2016-01-28 20:38:16-08:00 America/Los_Angeles (TRIAL RELEASE) - $Level affects all contexts once Test::Builder is loaded - Requires Test2 0.000023 Test-Simple 1.302013_011 2016-01-14 21:55:28-08:00 America/Los_Angeles (TRIAL RELEASE) - Performance enhancements Test-Simple 1.302013_010 2016-01-12 05:57:43-08:00 America/Los_Angeles (TRIAL RELEASE) - Changes needed for Test2 0.000018 Test-Simple 1.302013_009 2016-01-11 16:35:57-08:00 America/Los_Angeles (TRIAL RELEASE) - Make skip work without a count w/ done_testing (#629) - Require newer Test2 that fixes $! squashing (#628) Test-Simple 1.302013_008 2016-01-10 13:21:02-08:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version requirement (to fix downstream) Test-Simple 1.302013_007 2016-01-07 19:30:04-08:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version requirement Test-Simple 1.302013_006 2016-01-06 11:21:48-08:00 America/Los_Angeles (TRIAL RELEASE) - Update for Test2 0.000013 - Delay loading Data::Dumper - Test2::API::test2_no_wait(1) when threads/forking are on - Fix Test::Tester to use context - More downstream dists for testing Test-Simple 1.302013_005 2015-12-29 13:01:32-08:00 America/Los_Angeles (TRIAL RELEASE) - Updates for Test2 0.000012 - Helper for Test::SharedFork Test-Simple 1.302013_004 2015-12-28 13:12:23-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix diag/note bugs from refactor Test-Simple 1.302013_003 2015-12-22 09:41:46-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix bug in details() structure for subtests when the parent is todo Test-Simple 1.302013_002 2015-12-21 13:21:51-08:00 America/Los_Angeles (TRIAL RELEASE) - Updates for Test2 0.000010 Test-Simple 1.302013_001 2015-12-21 10:07:42-08:00 America/Los_Angeles (TRIAL RELEASE) - Switch to using Test2 under the hood - Use Dist::Zilla for releases - Reformat Changes file Test-Simple 1.302012_004 2015-Nov-16 07:45:11-08:00 PST * Fix #600 - done_testing($count) Test-Simple 1.302012_003 2015-Oct-27 00:02:44-08:00 PST * Fix typo that called wrong 'try' Test-Simple 1.302012_002 2015-Oct-02 21:57:19-08:00 PST * Add version eval to several modules (#605) Test-Simple 1.302012_001 2015-Oct-01 15:47:39-08:00 PST * Support for Test::Stream 1.302012 Test-Simple 1.302010_001 2015-Sep-29 21:18:38-08:00 PST * Support for Test::Stream 1.302010 * Some upstream package names changed * Test::Stream's interface changed, tests needed to change too. Test-Simple 1.302007_004 2015-Jul-27 21:13:39-08:00 PST * Work around perlbug 125702 Test-Simple 1.302007_003 2015-Jul-24 08:34:46-08:00 PST * Remove singleton from closure Test-Simple 1.302007_002 2015-Jul-18 17:38:26-08:00 PST * Fix subtest + Test::Stream::Tester Test-Simple 1.302007_001 2015-Jun-24 08:06:00-08:00 PST * Tests no longer copy thread/fork checks * Bump minimum Test::Stream version Test-Simple 1.302004_001 2015-Jun-17 08:33:00-08:00 PST * Update for newer Test-Stream with XS support * Use 'fudge' in Test::Stream instead of doing level adjustments here * Fix minor POD encoding issue #593 * Some performance enhancements in T::B->ok Test-Simple 1.302003_001 2015-Jan-06 21:52:00-08:00 PST * Convert internals to use Test-Stream * Optimizations for performance * Note this is a completely new branch off of legacy/master, not taken from the old stream branches Test-Simple 1.001014 2014-Dec-28 08:31:00-08:00 PST * Write a test to ensure this changes file gets updated * Update changes file for 1.001013 Test-Simple 1.001013 2014-Dec-28 08:00:00-08:00 PST * Fix a unit test that broke on some platforms with spaces in the $^X path Test-Simple 1.001012 2014-Dec-23 07:39:00-08:00 PST * Move test that was dropped in the wrong directory Test-Simple 1.001011 2014-Dec-20 09:08:00-08:00 PST * Remove POD Coverage test Test-Simple 1.001010 2014-Dec-19 20:16:00-08:00 PST * Fix windows test bug #491 * Integrate Test::Tester and Test::use::ok for easier downgrade from trial Test-Simple 1.001009 2014-Nov-2 22:31:08-08:00 PST * Fix bug in cmp_ok Test-Simple 1.001008 2014-Oct-15 20:10:22-08:00 PST * Updated Changes file Test-Simple 1.001007 2014-Oct-15 16:37:11-08:00 PST * Fix subtest name when skip_all is used Test-Simple 1.001006 2014-Sep-2 14:39:05-08:00 PST * Reverted change that is now part of alpha branch Test-Simple 1.001005 2014-Sep-2 19:47:19-08:00 JST * Changed install path for perl 5.12 or higher. Test-Simple 1.001004_003 2014-May-17 13:43-08:00 PST * Another Minor doc fix to solve test bug * Fix #399, conflict with strawberry-portable Test-Simple 1.001004_002 2014-May-17 13:43-08:00 PST * Minor doc fix to solve test bug Test-Simple 1.001004_001 2014-May-10 08:39-08:00 PST * Doc updates * Subtests accept args * Outdent subtest diag Test-Simple 1.001003 2014-Mar-21 21:12-08:00 PST * Doc updates for maintainer change Test-Simple 1.001002 2013-Nov-4 15:13-08:00 EST * no changes since 0.99 Test-Simple 1.001001_001 2013-Oct-30 20:47-08:00 EDT * no code changes, just a new version number with more room to grow Test-Simple 0.99 2013-Oct-29 13:21:03-08:00 EDT * restore ability to use regex with test_err and test_out (Zefram) [rt.cpan.org #89655] [github #389] [github #387] Test-Simple 0.99 2013-Oct-12 15:05-08:00 EDT * no changes since 0.98_06 Test-Simple 0.98_06 2013-Sep-27 10:11-08:00 EDT Bug Fixes * Fix precedence error with (return ... and ...) (nthykier) [github #385] Test-Simple 0.98_05 2013-Apr-23 17:33-08:00 PDT Doc Changes * Add a shorter work around for the UTF-8 output problem. (Michael G Schwern) Bug Fixes * Test::Builder::Tester now works with subtests. (Michael G Schwern) [github 350] * Fix test_fail() inside a do statement. (nnutter) [github #369] New Features * A subtest will put its name at the front of its results to make subtests easier to read. [github #290] [github #364] (Brendan Byrd) Feature Changes * like() and unlike() no longer warn about undef. [github #335] (Michael G Schwern) Test-Simple 0.98_04 2013-Apr-14 10:54-08:00 BST Distribution Changes * Scalar::Util 1.13 (ships with Perl 5.8.1) is now required. (Michael G Schwern) Feature Changes * The default name and diagnostics for isa_ok() and new_ok() have changed. (Michael G Schwern) Docs Fixes * Added a COMPATIBILITY section so users know what major features were added with what version of Test::More or perl. [github 343] [github 344] (pdl) * Fix the ok() example with grep(). (derek.mead@gmail.com) Bug Fixes * A test with no plan and missing done_testing() now exits with non-zero. [github #341] (tokuhirom) * isa_ok() tests were broken in 5.17 because of a change in method resolution. [github #353] (Michael G Schwern) Test-Simple 0.98_03 2012-Jun-21 13:04-08:00 PDT New Features * cmp_ok() will error when used with something which is not a comparison operator, including =, += and the like. [github 141] (Matthew Horsfall) Bug Fixes * use_ok() was calling class->import without quoting which could cause problems if "class" is also a function. Doc Fixes * use_ok() has been discouraged and de-emphasized as a general replacement for `use` in tests. [github #288] * $thing is now $this in the docs to avoid confusing users of other languages. [Karen Etheridge] Incompatible Changes With Previous Alphas (0.98_01) * use_ok() will no longer apply lexical pragams. The incompatibilities and extra complexity is not worth the marginal use. [github #287] Test-Simple 0.98_02 2011-Nov-24 01:13-08:00 PST Bug Fixes * use_ok() in 0.98_01 was leaking pragmas from inside Test::More. This looked like Test::More was forcing strict. [rt.cpan.org 67538] (Father Chrysostomos) Test-Simple 0.98_01 2011-Nov-8 17:07-08:00 PST Bug Fixes * BAIL_OUT works inside a subtest. (Larry Leszczynski) [github #138] * subtests now work with threads turned on. [github #145] Feature Changes * use_ok() will now apply lexical effects. [rt.cpan.org 67538] (Father Chrysostomos) Misc * Test::More, Test::Simple and Test::Builder::Module now require a minimum version of Test::Builder. This avoids Test::More and Test::Builder from getting out of sync. [github #89] Test-Simple 0.98 2011-Fev-23 14:38:02 +1100 Bug Fixes * subtest() should not fail if $? is non-zero. (Aaron Crane) Docs * The behavior of is() and undef has been documented. (Pedro Melo) Test-Simple 0.97_01 2010-Aug-27 22:50-08:00 PDT Test Fixes * Adapted the tests for the new Perl 5.14 regex stringification. (Karl Williamson) [github 44] Doc Fixes * Document how to test "use Foo ()". (Todd Rinaldo) [github 41] Feature Changes * subtest() no longer has a prototype. It was just getting in the way. [rt.cpan.org 54239] * The filehandles used by default will now inherit any filehandle disciplines from STDOUT and STDERR IF AND ONLY IF they were applied before Test::Builder is loaded. More later. [rt.cpan.org 46542] Test-Simple 0.96 2010-Aug-10 21:13-08:00 PDT Bug Fixes * You can call done_testing() again after reset() [googlecode 59] Other * Bug tracker moved to github Test-Simple 0.95_02 2010-May-19 15:46-08:00 PDT Bug Fixes * Correct various typos and spelling errors (Nick Cleaton) * Fix alignment of indented multi-line diagnostics from subtests (Nick Cleaton) * Fix incorrect operation when subtest called from within a todo block (Nick Cleaton) * Avoid spurious output after a fork within a subtest (Nick Cleaton) Test-Simple 0.95_01 2010-Mar-3 15:36-08:00 PST Bug Fixes * is_deeply() didn't see a difference in regexes [rt.cpan.org 53469] * Test::Builder::Tester now sets $tb->todo_output to the output handle and not the error handle (to be in accordance with the default behaviour of Test::Builder and allow for testing TODO test behaviour). * Fixed file/line in failing subtest() diagnostics. (Nick Cleaton) * Protect against subtests setting $Level (Nick Cleaton) New Features * subtests without a 'plan' or 'no_plan' have an implicit 'done_testing()' added to them. * is_deeply() performance boost for large structures consisting of mostly non-refs (Nick Cleaton) Feature Changes * is() and others will no longer stringify its arguments before comparing. Overloaded objects will make use of their eq overload rather than their "" overload. This can break tests of impolitely string overloaded objects. DateTime prior to 0.54 is the biggest example. Test-Simple 0.94 2009-Sep-2 11:17-08:00 PDT Releasing 0.93_01 as stable. Test-Simple 0.93_01 2009-Jul-20 09:51-08:00 PDT Bug Fixes * Make sure that subtest works with Test:: modules which call Test::Builder->new at the top of their code. (Ovid) Other * subtest() returns! Test-Simple 0.92 2009-Jul-3 11:08-08:00 PDT Test Fixes * Silence noise on VMS in exit.t (Craig Berry) * Skip Builder/fork_with_new_stdout.t on systems without fork (Craig Berry) Test-Simple 0.90 2009-Jul-2 13:18-08:00 PDT Docs * Note the IO::Stringy license in our copy of it. [test-more.googlecode.com 47] Other * This is a stable release for 5.10.1. It does not include the subtest() work in 0.89_01. Test-Simple 0.89_01 2009-Jun-23 15:13-08:00 EDT New Features * subtest() allows you to run more tests in their own plan. (Thanks Ovid!) * Test::Builder->is_passing() will let you check if the test is currently passing. Docs * Finally added a note about the "Wide character in print" warning and how to work around it. Test Fixes * Small fixes for integration with the Perl core [bleadperl eaa0815147e13cd4ab5b3d6ca8f26544a9f0c3b4] * exit code tests could be affected by errno when PERLIO=stdio [bleadperl c76230386fc5e6fba9fdbeab473abbf4f4adcbe3] Test-Simple 0.88 2009-May-30 12:31-08:00 PDT Turing 0.87_03 into a stable release. Test-Simple 0.87_03 2009-May-24 13:41-08:00 PDT New Features * isa_ok() now works on classes. (Peter Scott) Test-Simple 0.87_02 2009-Apr-11 12:54-08:00 PDT Test Fixes * Some filesystems don't like it when you open a file for writing multiple times. Fixes t/Builder/reset.t. [rt.cpan.org 17298] * Check how an operating system is going to map exit codes. Some OS' will map them... sometimes. [rt.cpan.org 42148] * Fix Test::Builder::NoOutput on 5.6.2. Test-Simple 0.87_01 2009-Mar-29 09:56-08:00 BST New Features * done_testing() allows you to declare that you have finished running tests, and how many you ran. It is a safer no_plan and effectively replaces it. * output() now supports scalar references. Feature Changes * You can now run a test without first declaring a plan. This allows done_testing() to work. * You can now call current_test() without first declaring a plan. Bug Fixes * skip_all() with no reason would output "1..0" which is invalid TAP. It will now always include the SKIP directive. Other * Repository moved to github. Test-Simple 0.86 2008-Nov-9 01:09-08:00 PST Same as 0.85_01 Test-Simple 0.85_01 2008-Oct-23 18:57-08:00 PDT New Features * cmp_ok() now displays the error if the comparison throws one. For example, broken overloaded objects. Bug Fixes * cmp_ok() no longer stringifies or numifies its arguments before comparing. This makes cmp_ok() properly test overloaded ops. [rt.cpan.org 24186] [code.google.com 16] * diag() properly escapes blank lines. Feature Changes * cmp_ok() now reports warnings and errors as coming from inside cmp_ok, as well as reporting the caller's file and line. This let's the user know where cmp_ok() was called from while reminding them that it is being run in a different context. Other * Dependency on ExtUtils::MakeMaker 6.27 only on Windows otherwise the nested tests won't run. Test-Simple 0.84 2008-Oct-15 09:06-08:00 EDT Other * 0.82 accidentally shipped with experimental Mouse dependency. Test-Simple 0.82 2008-Oct-14 23:06-08:00 EDT Bug Fixes - 0.81_01 broke $TODO such that $TODO = '' was considered todo. Test-Simple 0.81_02 2008-Sep-9 04:35-08:00 PDT New Features * Test::Builder->reset_outputs() to reset all the output methods back to their defaults. Bug Fixes - Fixed the file and line number reported by like when it gets a bad regex. Feature Changes - Now preserves the tests' exit code if it exits abnormally, rather than setting it to 255. - Changed the "Looks like your test died" message to "Looks like your test exited with $exit_code" - no_plan now only warns if given an argument. There were a lot of people doing that, and it's a sensible mistake. [test-more.googlecode.com 13] Test-Simple 0.81_01 2008-Sep-6 15:13-08:00 PDT New Features * Adam Kennedy bribed me to add new_ok(). The price was one DEFCON license key. [rt.cpan.org 8891] * TODO tests can now start and end with 'todo_start' and 'todo_end' Test::Builder methods. [rt.cpan.org 38018] * Added Test::Builder->in_todo() for a safe way to check if a test is inside a TODO block. This allows TODO tests with no reason. * Added note() and explain() to both Test::More and Test::Builder. [rt.cpan.org 14764] [test-more.googlecode.com 3] Feature Changes * Changed the message for extra tests run to show the number of tests run rather than the number extra to avoid the user having to do mental math. [rt.cpan.org 7022] Bug fixes - using a relative path to perl broke tests [rt.cpan.org 34050] - use_ok() broke $SIG{__DIE__} in the used module [rt.cpan.org 34065] - diagnostics for isnt() were confusing on failure [rt.cpan.org 33642] - warnings when MakeMaker's version contained _ [rt.cpan.org 33626] - add explicit test that non-integer plans die correctly [rt.cpan.org 28836] (Thanks to Hans Dieter Pearcey [confound] for fixing the above) - die if no_plan is given an argument [rt.cpan.org 27429] Test-Simple 0.80 2008-Apr-6 17:25-08:00 CEST Test fixes - Completely disable the utf8 test. It was causing perl to panic on some OS's. Test-Simple 0.79_01 2008-Feb-27 03:04-08:00 PST Bug fixes - Let's try the IO layer copying again, this time with the test fixed for 5.10. Test-Simple 0.78 2008-Feb-27 01:59-08:00 PST Bug fixes * Whoops, the version of Test::Builder::Tester got moved backwards. Test-Simple 0.77 2008-Feb-27 01:55-08:00 PST Bug fixes - "use Test::Builder::Module" no longer sets exported_to() or does any other importing. - Fix the $TODO finding code so it can find $TODO without the benefit of exported_to(), which is often wrong. - Turn off the filehandle locale stuff for the moment, there's a problem on 5.10. We'll try it again next release. Doc improvements - Improve the Test::Builder SYNOPSIS to use Test::Builder::Module rather than write its own import(). Test-Simple 0.76_02 2008-Feb-24 13:12-08:00 PST Bug fixes * The default test output filehandles will NOT use utf8. They will now copy the IO layers from STDOUT and STDERR. This means if :utf8 is on then it will honor it and not warn about wide characters. Test-Simple 0.76_01 2008-Feb-23 20:44-08:00 PST Bug fixes * Test::Builder no longer uses a __DIE__ handler. This resolves a number of problems with exit codes being swallowed or other module's handlers being interfered with. [rt.cpan.org 25294] - Allow maybe_regex() to detect blessed regexes. [bleadperl @32880] - The default test output filehandles will now use utf8. [rt.cpan.org 21091] Test fixes - Remove the signature test. Adds no security and just generates failures. Test-Simple 0.75 2008-Feb-23 19:03-08:00 PST Incompatibilities * The minimum version is now 5.6.0. Bug fixes - Turns out require_ok() had the same bug as use_ok() in a BEGIN block. - ok() was not honoring exported_to() when looking for $TODO as it should be. Test fixes * is_deeply_with_threads.t will not run unless AUTHOR_TESTING is set. This is because it tickles intermittent threading bugs in many perls and causes a lot of bug reports about which I can do nothing. Misc - Ran through perlcritic and did some cleaning. Test-Simple 0.74 2007-Nov-29 15:39-08:00 PST Misc - Add abstract and author to the meta information. Test-Simple 0.73_01 2007-Oct-15 20:35-08:00 EDT Bug fixes * Put the use_ok() fix from 0.71 back. Test-Simple 0.72 2007-Sep-19 20:08-08:00 PDT Bug unfixes * The BEGIN { use_ok } fix for [rt.cpan.org 28345] revealed a small pile of mistakes in CPAN module test suites. Rolling the fix back to give the authors a bit of time to fix their tests. Test-Simple 0.71 2007-Sep-13 20:42-08:00 PDT Bug fixes - Fixed a problem with BEGIN { use_ok } silently failing when there's no plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak. - Fixed an obscure problem with is_deeply() and overloading == [rt.cpan.org 20768]. Thanks Sisyphus. Test fixes - Removed dependency on Text::Soundex [rt.cpan.org 25022] - Fixed a 5.5.x failure in fail-more.t * Got rid of the annoying sort_bug.t test that revealed problems with some threaded perls. It was testing the deprecated eq_* functions and not worth the bother. Now it tests is_deeply(). [rt.cpan.org 17791] Doc fixes - Minor POD mistake in Test::Builder [rt.cpan.org 28869] * Test::FAQ has been updated with some more answers. Install fixes - Fixed the "LICENSE is not a known MakeMaker parameter name" warning on older MakeMakers for real this time. Test-Simple 0.70 2007-Mar-15 15:53-08:00 PDT Bug Fixes * The change to is_fh() in 0.68 broke the case where a reference to a tied filehandle is used for perl 5.6 and back. This made the tests puke their guts out. Test-Simple 0.69 2007-Mar-14 06:43-08:00 PDT Test fixes - Minor filename compatibility fix to t/fail-more.t [rt.cpan.org 25428] Test-Simple 0.68 2007-Mar-13 17:27-08:00 PDT Bug fixes * If your code has a $SIG{__DIE__} handler in some cases functions like use_ok(), require_ok(), can_ok() and isa_ok() could trigger that handler. [rt.cpan.org 23509] - Minor improvement to TB's filehandle detection in the case of overridden isa(). [rt.cpan.org 20890] - Will now install as a core module in 5.6.2 which ships with Test::More. [rt.cpan.org 25163] New Features - Test::Builder->is_fh() provides a way to determine if a thing can be used as a filehandle. Documentation improvements - Improved the docs for $Test::Builder::Level showing the encouraged use (increment, don't set) - Documented the return value of Test::Builder's test methods - Split out TB's method documentation to differenciate between test methods (ok, is_eq...), methods useful in testing (skip, BAILOUT...) and methods useful for building your own tests (maybe_regex...). Test fixes - We required too old a version of Test::Pod::Coverage. Need 1.08 and not 1.00. [rt.cpan.org 25351] Test-Simple 0.67 2007-Jan-22 13:27-08:00 PST Test fixes - t/pod_coverage.t would fail if Test::Pod::Coverage between 1.07 and 1.00 were installed as it depended on all_modules being exported. [rt.cpan.org 24483] Test-Simple 0.66 2006-Dec-3 15:25-08:00 PST - Restore 5.4.5 compatibility (unobe@cpan.org) [rt.cpan.org 20513] Test-Simple 0.65 2006-Nov-10 10:26-08:00 CST Test-Simple 0.64_03 2006-Nov-5 13:09-08:00 EST - Tests will no longer warn when run against an alpha version of Test::Harness [rt.cpan.org #20501] - Now testing our POD and POD coverage. - Added a LICENSE field. - Removed warning from the docs about mixing numbered and unnumbered tests. There's nothing wrong with that. [rt.cpan.org 21358] - Change doc examples to talk about $got and $expected rather than $this and $that to correspond better to the diagnostic output [rt.cpan.org 2655] Test-Simple 0.64_02 2006-Sep-9 12:16-08:00 EDT - Last release broke Perls earlier than 5.8. Test-Simple 0.64_01 2006-Sep-4 04:40-08:00 EDT - Small improvement to the docs to avoid user confusion over "use Test::More tests => $num_tests" (Thanks Eric Wilhelm) - Minor fix for a test failure in is_deeply_fail for some Windows users. Not a real bug. [rt.cpan.org 21310] - _print_diag() accidentally leaked into the public documentation. It is a private method. * Added Test::Builder->carp() and croak() * Made most of the error messages report in the caller's context. [rt.cpan.org #20639] * Made the failure diagnostic message file and line reporting portion match Perl's for easier integration with Perl aware editors. (so its "at $file line $line_num." now) [rt.cpan.org #20639] * 5.8.0 threads are no longer supported. There's too many bugs. Test-Simple 0.64 2006-Jul-16 02:47-08:00 PDT * 0.63's change to test_fail() broke backwards compatibility. They have been removed for the time being. test_pass() went with it. This is [rt.cpan.org 11317] and [rt.cpan.org 11319]. - skip() will now warn if you get the args backwards. Test-Simple 0.63 2006-Jul-9 02:36-08:00 PDT * Fixed can_ok() to gracefully handle no class name. Submitted by "Pete Krawczyk" Implemented by "Richard Foley" [rt.cpan.org 15654] * Added test_pass() to Test::Builder::Tester rather than having to call test_out("ok 1 - foo"). [rt.cpan.org 11317] * test_fail() now accepts a test diagnostic rather than having to call test_out() separately. [rt.cpan.org 11319] - Changed Test::Builder::Tester docs to show best practice using test_fail() and test_pass(). - isnt_num() doc example wrongly showed is_num(). - Fixed a minor typo in the BAIL_OUT() docs. - Removed the LICENSE field from the Makefile.PL as the release of MakeMaker with that feature has been delayed. Test-Simple 0.62 2005-Oct-8 01:25-08:00 PDT * Absorbed Test::Builder::Tester. The last release broke it because its screen scraping Test::More and the failure output changed. By distributing them together we ensure TBT won't break again. * Test::Builder->BAILOUT() was missing. - is_deeply() can now handle function and code refs in a very limited way. It simply looks to see if they have the same referent. [rt.cpan.org 14746] Test-Simple 0.61 2005-Sep-23 23:26-08:00 PDT - create.t was trying to read from a file before it had been closed (and thus the changes may not have yet been written). * is_deeply() would call stringification methods on non-object strings which happened to be the name of a string overloaded class. [rt.cpan.org 14675] Test-Simple 0.60_02 2005-Aug-9 00:27-08:00 PDT * Added Test::Builder::Module. - Changed Test::More and Test::Simple to use Test::Builder::Module - Minor Win32 testing nit in fail-more.t * Added no_diag() method to Test::Builder and changed Test::More's no_diag internals to use that. [rt.cpan.org 8655] * Deprecated no_diag() as an option to "use Test::More". Call the Test::Builder method instead. Test-Simple 0.60_01 2005-Jul-3 18:11-08:00 PDT - Moved the docs around a little to better group all the testing functions together. [rt.cpan.org 8388] * Added a BAIL_OUT() function to Test::More [rt.cpan.org 8381] - Changed Test::Builder->BAILOUT to BAIL_OUT to match other method's naming conventions. BAILOUT remains but is deprecated. * Changed the standard failure diagnostics to include the test name. [rt.cpan.org 12490] - is_deeply() was broken for overloaded objects in the top level in 0.59_01. [rt.cpan.org 13506] - String overloaded objects without an 'eq' or '==' method are now handled in cmp_ok() and is(). - cmp_ok() will now treat overloaded objects as numbers if the comparison operator is numeric. [rt.cpan.org 13156] - cmp_ok(), like() and unlike will now throw uninit warnings if their arguments are undefined. [rt.cpan.org 13155] - cmp_ok() will now throw warnings as if the comparison were run normally, for example cmp_ok(2, '==', 'foo') will warn about 'foo' not being numeric. Previously all warnings in the comparison were suppressed. [rt.cpan.org 13155] - Tests will now report *both* the number of tests failed and if the wrong number of tests were run. Previously if tests failed and the wrong number were run it would only report the latter. [rt.cpan.org 13494] - Missing or extra tests are not considered failures for the purposes of calculating the exit code. Should there be no failures but the wrong number of tests the exit code will be 254. - Avoiding an unbalanced sort in eq_set() [bugs.perl.org 36354] - Documenting that eq_set() doesn't deal well with refs. - Clarified how is_deeply() compares a bit. * Once again working on 5.4.5. Test-Simple 0.60 2005-May-3 14:20-08:00 PDT Test-Simple 0.59_01 2005-Apr-26 21:51-08:00 PDT * Test::Builder now has a create() method which allows you to create a brand spanking new Test::Builder object. * require_ok() was not working for single letter module names. * is_deeply() and eq_* now work with circular scalar references (Thanks Fergal) * Use of eq_* now officially discouraged. - Removed eq_* from the SYNOPSIS. - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441] - is_deeply() was mistakenly interpreting the same reference used twice in a data structure as being circular causing failures. [rt.cpan.org 11623] - Loading Test::Builder but not using it would interfere with the exit code if the code exited. [rt.cpan.org 12310] - is_deeply() diagnostics now disambiguate between stringified references and references. [rt.cpan.org 8865] - Files opened by the output methods are now autoflushed. - todo() now honors $Level when looking for $TODO. Test-Simple 0.54 2004-Dec-15 04:18-08:00 EST * $how_many is optional for skip() and todo_skip(). Thanks to Devel::Cover for pointing this out. - Removed a user defined function called err() in the tests to placate users of older versions of the dor patch before err() was weakend. [rt.cpan.org 8734] Test-Simple 0.53_01 2004-Dec-11 19:02-08:00 EST - current_test() can now be set backward. - *output() methods now handle tied handles and *FOO{IO} properly. - maybe_regex() now handles undef gracefully. - maybe_regex() now handles 'm,foo,' style regexes. - sort_bug.t wasn't checking for threads properly. Would fail on 5.6 that had ithreads compiled in. [rt.cpan.org 8765] Test-Simple 0.53 2004-Nov-29 04:43-08:00 EST - Apparently its possible to have Module::Signature installed without it being functional. Fixed the signature test to account for this. (not a real bug) Test-Simple 0.52 2004-Nov-28 21:41-08:00 EST - plan() now better checks that the given plan is valid. [rt.cpan.org 2597] Test-Simple 0.51_02 2004-Nov-27 01:25-08:00 EST * is_deeply() and all the eq_* functions now handle circular data structures. [rt.cpan.org 7289] * require_ok() now handles filepaths in addition to modules. - Clarifying Test::More's position on overloaded objects - Fixed a bug introduced in 0.51_01 causing is_deeply() to pierce overloaded objects. - Mentioning rt.cpan.org for reporting bugs. Test-Simple 0.51_01 2004-Nov-26 02:59-08:00 EST - plan() was accidentally exporting functions [rt.cpan.org 8385] * diag @msgs would insert # between arguments. [rt.cpan.org 8392] * eq_set() could cause problems under threads due to a weird sort bug [rt.cpan.org 6782] * undef no longer equals '' in is_deeply() [rt.cpan.org 6837] * is_deeply() would sometimes compare references as strings. [rt.cpan.org 7031] - eq_array() and eq_hash() could hold onto references if they failed keeping them in memory and preventing DESTROY. [rt.cpan.org 7032] * is_deeply() could confuse [] with a non-existing value [rt.cpan.org 7030] - is_deeply() diagnostics a little off when scalar refs were inside an array or hash ref [rt.cpan.org 7033] - Thanks to Fergal Daly for ferretting out all these long standing is_deeply and eq_* bugs. Test-Simple 0.51 2004-Nov-23 04:51-08:00 EST - Fixed bug in fail_one.t on Windows (not a real bug). - TODO reasons as overloaded objects now won't blow up under threads. [Autrijus Tang] - skip() in 0.50 tickled yet another bug in threads::shared. Hacked around it. Test-Simple 0.50 2004-Nov-20 00:28-08:00 EST - Fixed bug in fail-more test on Windows (not a real bug). [rt.cpan.org 8022] - Change from CVS to SVK. Hopefully this is the last time I move version control systems. - Again removing File::Spec dependency (came back in 0.48_02) - Change from Aegis back to CVS Test-Simple 0.49 2004-Oct-14 21:58-08:00 EDT - t/harness_active.t would fail for frivolous reasons with older MakeMakers (test bug) [thanks Bill Moseley for noticing] Test-Simple 0.48_02 2004-Jul-19 02:07-08:00 EDT * Overloaded objects as names now won't blow up under threads [rt.cpan.org 4218 and 4232] * Overloaded objects which stringify to undef used as test names now won't cause internal uninit warnings. [rt.cpan.org 4232] * Failure diagnostics now come out on their own line when run in Test::Harness. - eq_set() sometimes wasn't giving the right results if nested refs were involved [rt.cpan.org 3747] - isnt() giving wrong diagnostics and warning if given any undefs. * Give unlike() the right prototype [rt.cpan.org 4944] - Change from CVS to Aegis - is_deeply() will now do some basic argument checks to guard against accidentally passing in a whole array instead of its reference. - Mentioning Test::Differences, Test::Deep and Bundle::Test. - Removed dependency on File::Spec. - Fixing the grammar of diagnostic outputs when only a single test is run or failed (ie. "Looks like you failed 1 tests"). [Darren Chamberlain] Test-Simple 0.48_01 2002-Nov-11 02:36-08:00 EST - Mention Test::Class in Test::More's SEE ALSO * use_ok() now DWIM for version checks - More problems with ithreads fixed. * Test::Harness upgrade no longer optional. It was causing too many problems when the T::H upgrade didn't work. * Drew Taylor added a 'no_diag' option to Test::More to switch off all diag() statements. * Test::Builder/More no longer automatically loads threads.pm when threads are enabled. The user must now do this manually. * Alex Francis added reset() reset the state of Test::Builder in persistent environments. - David Hand noted that Test::Builder/More exit code behavior was not documented. Only Test::Simple. Test-Simple 0.47 2002-Aug-26 03:54-08:00 PDT * Tatsuhiko Miyagawa noticed Test::Builder was accidentally storing objects passed into test functions causing problems with tests relying on object destruction. - Added example of calculating the number of tests to Test::Tutorial - Peter Scott made the ending logic not fire on child processes when forking. * Test::Builder is once again ithread safe. Test-Simple 0.46 2002-Jul-20 19:57-08:00 EDT - Noted eq_set() isn't really a set comparison. - Test fix, exit codes are broken on MacPerl (bleadperl@16868) - Make Test::Simple install itself into the core for >= 5.8 - Small fixes to Test::Tutorial and skip examples * Added TB->has_plan() from Adrian Howard - Clarified the meaning of 'actual_ok' from TB->details * Added TB->details() from chromatic - Neil Watkiss fixed a pre-5.8 test glitch with threads.t * If the test died before a plan, it would exit with 0 [ID 20020716.013] Test-Simple 0.45 2002-Jun-19 18:41-08:00 EDT - Andy Lester made the SKIP & TODO docs a bit clearer. - Explicitly disallowing double plans. (RT #553) - Kicking up the minimum version of Test::Harness to one that's fairly bug free. - Made clear a common problem with use_ok and BEGIN blocks. - Arthur Bergman made Test::Builder thread-safe. Test-Simple 0.44 2002-Apr-25 00:27-08:00 EDT - names containing newlines no longer produce confusing output (from chromatic) - chromatic provided a fix so can_ok() honors can() overrides. - Nick Ing-Simmons suggested todo_skip() be a bit clearer about the skipping part. - Making plan() vomit if it gets something it doesn't understand. - Tatsuhiko Miyagawa fixed use_ok() with pragmata on older perls. - quieting diag(undef) Test-Simple 0.43 2002-Apr-11 22:55-08:00 EDT - Adrian Howard added TB->maybe_regex() - Adding Mark Fowler's suggestion to make diag() return false. - TB->current_test() still not working when no tests were run via TB itself. Fixed by Dave Rolsky. Test-Simple 0.42 2002-Mar-6 15:00-08:00 EST - Setting Test::Builder->current_test() now works (see what happens when you forget to test things?) - The change in is()'s undef/'' handling in 0.34 was an API change, but I forgot to declare it as such. - The apostrophilic jihad attacks! Philip Newtons patch for grammar mistakes in the doc's. Test-Simple 0.41 2001-Dec-17 22:45-08:00 EST * chromatic added diag() - Internal eval()'s sometimes interfering with $@ and $!. Fixed. Test-Simple 0.40 2001-Dec-14 15:41-08:00 EST * isa_ok() now accepts unblessed references gracefully - Nick Clark found a bug with like() and a regex with % in it. - exit.t was hanging on 5.005_03 VMS perl. Test now skipped. - can_ok() would pass if no methods were given. Now fails. - isnt() diagnostic output format changed * Added some docs about embedding and extending Test::More * Added Test::More->builder * Added cmp_ok() * Added todo_skip() * Added unlike() - Piers pointed out that sometimes people override isa(). isa_ok() now accounts for that. Test-Simple 0.36 2001-Nov-29 14:07-08:00 EST - Matthias Urlichs found that intermixed prints to STDOUT and test output came out in the wrong order when piped. Test-Simple 0.35 2001-Nov-27 19:57-08:00 EST - Little glitch in the test suite. No actual bug. Test-Simple 0.34 2001-Nov-27 15:43-08:00 EST * **API CHANGE** Empty string no longer matches undef in is() and isnt(). * Added isnt_eq and isnt_num to Test::Builder. Test-Simple 0.33 2001-Oct-22 21:05-08:00 EDT * It's now officially safe to redirect STDOUT and STDERR without affecting test output. - License and POD cleanup by Autrijus Tang - Synched up Test::Tutorial with the wiki version - Minor VMS test nit. Test-Simple 0.32 2001-Oct-16 16:52-08:00 EDT * Finally added a separate plan() function * Adding a name field to isa_ok() (Requested by Dave Rolsky) - Test::More was using Carp.pm, causing the occasional false positive. (Reported by Tatsuhiko Miyagawa) Test-Simple 0.31 2001-Oct-8 19:24-08:00 EDT * Added an import option to Test::More * Added no_ending and no_header options to Test::Builder (Thanks to Dave Rolsky for giving this a swift kick in the ass) * Added is_deeply(). Display of scalar refs not quite 100% (Thanks to Stas Bekman for Apache::TestUtil idea thievery) - Fixed a minor warning with skip() (Thanks to Wolfgang Weisselberg for finding this one) Test-Simple 0.30 2001-Sep-27 22:10-08:00 EDT * Added Test::Builder (Thanks muchly to chromatic for getting this off the ground!) * Diagnostics are back to using STDERR *unless* it's from a todo test. Those go to STDOUT. - Fixed it so nothing is printed if a test is run with a -c flag. Handy when a test is being deparsed with B::Deparse. Test-Simple 0.20 *UNRELEASED* Test-Simple 0.19 2001-Sep-18 17:48-08:00 EDT * Test::Simple and Test::More no longer print their diagnostics to STDERR. It instead goes to STDOUT. * TODO tests which fail now print full failure diagnostics. - Minor bug in ok()'s test name diagnostics made it think a blank name was a number. - ok() less draconian about test names - Added temporary special case for Parrot::Test - Now requiring File::Spec for our tests. Test-Simple 0.18 2001-Sep-5 20:35-08:00 EDT * ***API CHANGE*** can_ok() only counts as one test - can_ok() has better diagnostics - Minor POD fixes from mjd - adjusting the internal layout to make it easier to put it into the core Test-Simple 0.17 2001-Aug-29 20:16-08:00 EDT * Added can_ok() and isa_ok() to Test::More Test-Simple 0.16 2001-Aug-28 19:52-08:00 EDT * vmsperl foiled my sensible exit codes. Reverting to a much more coarse scheme. Test-Simple 0.15 2001-Aug-28 06:18-08:00 EDT *UNRELEASED* * Now using sensible exit codes on VMS. Test-Simple 0.14 2001-Aug-22 17:26-08:00 EDT * Added a first cut at Test::Tutorial Test-Simple 0.13 2001-Aug-14 15:30-08:00 EDT * Added a reason to the skip_all interface - Fixed a bug to allow 'use Test::More;' to work. (Thanks to Tatsuhiko Miyagawa again) - Now always testing backwards compatibility. Test-Simple 0.12 2001-Aug-14 11:02-08:00 EDT * Fixed some compatibility bugs with older Perls (Thanks to Tatsuhiko Miyagawa) Test-Simple 0.11 2001-Aug-11 23:05-08:00 EDT * Will no longer warn about testing undef values - Escaping # in test names - Ensuring that ok() returns true or false and not undef - Minor doc typo in the example Test-Simple 0.10 2001-Jul-31 15:01-08:00 EDT * Test::More is now distributed in this tarball. * skip and todo tests work! * Extended use_ok() so it can import - A little internal rejiggering - Added a TODO file Test-Simple 0.09 2001-Jun-27 02:55-08:00 EDT - VMS fixes Test-Simple 0.08 2001-Jun-15 14:39-08:00 EDT - Guarding against $/ and -l - Reformatted the way failed tests are reported to make them stand out a bit better. Test-Simple 0.07 2001-Jun-12 15:55-08:00 BST - 'use Test::Simple' by itself no longer causes death - Yet more fixes for death in eval - Limiting max failures reported via exit code to 254. Test-Simple 0.06 2001-May-9 23:38-08:00 BST - Whoops, left a private method in the public docs. Test-Simple 0.05 2001-May-9 20:40-08:00 BST - Forgot to include the exit tests. - Trouble with exiting properly under 5.005_03 and 5.6.1 fixed - Turned off buffering * 5.004 new minimum version - Now explicitly tested with 5.6.1, 5.6.0, 5.005_03 and 5.004 Test-Simple 0.04 2001-Apr-2 11:05-08:00 BST - Fixed "require Test::Simple" so it doesn't bitch and exit 255 - Now installable with the CPAN shell. Test-Simple 0.03 2001-Mar-30 08:08-08:00 BST - ok() now prints on what line and file it failed. - eval 'die' was considered abnormal. Fixed. Test-Simple 0.02 2001-Mar-30 05:12-08:00 BST *UNRELEASED* - exit codes tested * exit code on abnormal exit changed to 255 (thanks to Tim Bunce for pointing out that Unix can't do negative exit codes) - abnormal exits now better caught. - No longer using Test.pm to test this, but still minimum of 5.005 due to needing $^S. Test-Simple 0.01 2001-Mar-28 06:44-08:00 BST - First working version released to CPAN Test2 0.000044 2016-04-30 13:56:25-07:00 America/Los_Angeles - Remove things that should nto have been backported from Test-Simple merger Test2 0.000043 2016-04-30 05:21:51-07:00 America/Los_Angeles - Better error messages when using Carp in Hashbase init() - Document 2 methods on Events - Fix #17 (typo fix in docs) Test2 0.000042 2016-04-15 13:17:21-07:00 America/Los_Angeles - Let TAP render generic events - Add the no_display method to the Event API - Improve T2_FORMATTER parsing Test2 0.000041 2016-04-13 20:21:38-07:00 America/Los_Angeles - Do not use custom formatter in sensitive tests Test2 0.000040 2016-04-05 11:09:52-07:00 America/Los_Angeles - Track subtest info inside subtest events Test2 0.000039 2016-04-04 21:32:08-07:00 America/Los_Angeles - Formatters can pick buffered subtest behavior - Add sets_plan() method to event base class - Add diagnostics() method to event base class Test2 0.000038 2016-04-03 15:41:39-07:00 America/Los_Angeles - Add summary() method to event base class Test2 0.000037 2016-04-01 08:41:22-07:00 America/Los_Angeles - Change Formatter to load Test2::API on demand - Add test to insure Test2::API is not loaded by some modules Test2 0.000036 2016-03-28 11:44:53-07:00 America/Los_Angeles - Do not warn if unimportant INIT block cannot be run - Change how TAP duplicates IO handles, use 3 arg form of open Test2 0.000035 2016-03-25 09:41:46-07:00 America/Los_Angeles (TRIAL RELEASE) - More fixes for #16 - Add some END block manipulation for #16 - Turn off depth checking on older perls (for #16) Test2 0.000034 2016-03-24 10:32:57-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix depth bug introduced in the last trial Test2 0.000033 2016-03-24 08:39:51-07:00 America/Los_Angeles (TRIAL RELEASE) - Better fox for #16 (workaround for caller() in END bug) - Put test for #16 in regular testing dir as new fix is more stable Test2 0.000032 2016-03-23 23:54:40-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix #16 (workaround for caller() in END bug) Test2 0.000031 2016-03-20 13:45:43-07:00 America/Los_Angeles - Regenerate README files - Apply spelling fixes (aquire->acquire) #11 - Improve error message for missing hubs #12 Test2 0.000030 2016-03-15 08:04:21-07:00 America/Los_Angeles - Re-Add transition document Test2 0.000029 2016-03-09 10:04:19-08:00 America/Los_Angeles - Add pid to Files driver temp dir name Test2 0.000028 2016-03-09 09:03:26-08:00 America/Los_Angeles - Environment var to control IPC::Driver::Files temp dir templates Test2 0.000027 2016-03-07 12:16:34-08:00 America/Los_Angeles - Ability to disable skip_all subtest abort construct Test2 0.000026 2016-03-06 20:15:19-08:00 America/Los_Angeles - Version number in all modules (autarch) - Fix rare/minor Race condition in Files IPC driver - skip-all plan is not global anymore (never should have been) - skip-all properly aborts in child proc/thread - don't override defined but falsy pid/rid in traces Test2 0.000025 2016-02-02 12:08:32-08:00 America/Los_Angeles - Fix occasional warning in cleanup Test2 0.000024 2016-01-29 21:16:56-08:00 America/Los_Angeles - Add no_context() (needed for external tool) Test2 0.000023 2016-01-28 20:34:09-08:00 America/Los_Angeles - Add context_do() - Add context_aquire hooks - Documentation updates - Typo fixes (thanks rjbs) - Minor enhancement to test tools Test2 0.000022 2016-01-18 11:58:40-08:00 America/Los_Angeles - Fix test that broke in the last release (oops) Test2 0.000021 2016-01-18 10:54:54-08:00 America/Los_Angeles - Fix bug where default diagnostics were not shown for subtests. Test2 0.000020 2016-01-14 21:52:43-08:00 America/Los_Angeles - Change how contexts are stacked - More/better messages when contexts are abused - better handling of $@, $!, and $? - Add pre_filter and pre_unfilter to Hubs Test2 0.000019 2016-01-12 16:08:11-08:00 America/Los_Angeles - Make third-party meta-data interface consistent. Test2 0.000018 2016-01-12 05:53:29-08:00 America/Los_Angeles - Better solution to the $?, $!, and $@ problem - error vars are stored/restored by the context Test2 0.000017 2016-01-11 16:33:55-08:00 America/Los_Angeles - Fix $! squashing Test2 0.000016 2016-01-10 11:54:57-08:00 America/Los_Angeles - Better encapsulation of API::Instance - API methods to get lists of hooks - Minor fixes to IPC shm logic - Preload event types when API is loaded - Added IPC acceptance tests Test2 0.000015 2016-01-07 19:26:58-08:00 America/Los_Angeles - Make it possible to use a custom new() with HashBase Test2 0.000014 2016-01-07 07:31:23-08:00 America/Los_Angeles - Silence a warning in older perls (warning breaks Test-Simple tests) Test2 0.000013 2016-01-06 11:12:21-08:00 America/Los_Angeles - Remove diag from inside todo (separation of concerns, less TAP influence) - Remove internal TODO tracking (not needed, less TAP influence) - Make context less magic (Follwing advice from Graham Knop and RJBS) - Remove State.pm (part of Hub.pm again, no longer needs to be separate) - Make it possible to subclass the TAP formatter - Minor optimization in Event->meta - Better messaging if subtest plan is wrong - HashBase in subclass will not override accessors from parent (Graham Knop) - TAP formatter doc updates - Optimizations for Hub->process and TAP->Write - IPC File-Driver Optimizations - IPC use SHM when possible to notify about pending events Test2 0.000012 2015-12-29 12:59:26-08:00 America/Los_Angeles - Restructure file layout - Document namespaces - Combine Global and API into a single module Test2 0.000011 2015-12-28 13:09:38-08:00 America/Los_Angeles - Fix TAP output to match what Test::More produced Test2 0.000010 2015-12-21 13:13:33-08:00 America/Los_Angeles - Rename Test2.pm to Test2/API.pm. - Turn Global.pm into and exporter. Test2 0.000009 2015-12-21 10:13:18-08:00 America/Los_Angeles - Fix typo in Test2::Event Test2 0.000008 2015-12-21 09:54:58-08:00 America/Los_Angeles - Bring back 'release' export of Test2. Test2 0.000007 2015-12-20 12:09:04-08:00 America/Los_Angeles - Fix version number string - Fix typo Test2 0.000006 2015-12-15 20:30:46-08:00 America/Los_Angeles - Port 00-report.t from old form - Prevent TAP from killing $! - Fix Instance.t - Typo fix - Comment Contex.pm better, fix minor bug - Better error in Trace.pm constructor - Test2.pm, comments, and do not use try - Improve try, remove protect - Remove unused imports - Fix profling scripts - Improve HashBase - IPC improvements - Doc fix Test2 0.000005 2015-12-14 20:21:34-08:00 America/Los_Angeles - Pull out guts into Test2 namespace - Restructure module paths - Simplify HashBase - Combine Util and Capabilities - Update Profiling scripts - Rename DebugInfo to Trace - Rename SyncObj to Global/Instance - Slim down Util.pm - Stop using Test::Stream::Exporter - Reduce complexity of Capabilities checker - Use event todo instead of debuginfo todo - Add 'todo' fields for Diag and Ok events - Break out Skip into an event type - Add event registration to TAP formatter - Move to_tap logic into formatter Test-Stream 1.302026 2015-11-09 14:34:30-08:00 America/Los_Angeles - No functional changes since the last trial - Doc fix (fixes #52) - Doc fix (fixes #55) - Doc fix in Classic bundle - Doc fixes for FromTestBuilder Test-Stream 1.302025 2015-11-06 16:33:06-08:00 America/Los_Angeles (TRIAL RELEASE) - Add back cmp_ok in Core plugin - Add Classic plugin for legacy is/like/is_deeply/etc - Make docs recommend people moving from Test::More use -Classic Test-Stream 1.302024 2015-11-04 11:15:14-08:00 America/Los_Angeles - Add missing undef compare test Test-Stream 1.302023 2015-11-04 00:12:49-08:00 America/Los_Angeles (TRIAL RELEASE) - String and Number comparisons no longer allow undef (backwards-incompatible change, sorry) - Doc spelling fixes (Evan Zacks) - Add Undef type in deep check - Fix docs for buffered subtests (Noticed by Magnolia.K) Test-Stream 1.302022 2015-11-03 09:43:39-08:00 America/Los_Angeles - Change Delta.pm to use a grep instead of a map (minor change) - Fix scalar-ref comparison for overloaded scalar refs (#50) Test-Stream 1.302021 2015-10-31 08:15:22-07:00 America/Los_Angeles - Remove all number vs string guessing - Doc fixes (thanks Magnolia.K) - Add details to test report Test-Stream 1.302020 2015-10-29 08:02:25-07:00 America/Los_Angeles - No changes, just removing trial Test-Stream 1.302019 2015-10-28 22:32:06-07:00 America/Los_Angeles (TRIAL RELEASE) - Declare Test::Stream experimental phase complete - Updated Readme - Add tooling manual page - Better Trace::Mask behavior - Added Components manual page - Remove or modify experimental notice - Remove stray debugging statements - Slight change in module list in t/00-report.t Test-Stream 1.302018 2015-10-26 16:47:45-07:00 America/Los_Angeles - Better stack traces in spec - Remove duplicate module from the report - Rename subs in try {} and protect {} - Fix loop in SkipWithout - Fix Typo in Context pod Test-Stream 1.302017 2015-10-15 21:32:50-07:00 America/Los_Angeles - Change minimum module versions (they were wrong) - Typo fixes in Test::Stream docs - Remove unused variable - Fix Compare line number bug Test-Stream 1.302016 2015-10-12 18:49:35-07:00 America/Los_Angeles - Workflows/Spec: Argument tolerence, custom line numbers - Remove Block.pm - Add sub_info and sub_name to Util.pm - Workflows: Set sub name if possible (better debugging) - Add "Test" that prints deps and versions - Add 'class', 'skip_without', and 'srand' to Test::Stream as options - Even Core deps now listed in dist.ini - Add some missing docs and tests to Util.pm Test-Stream 1.302015 2015-10-04 13:46:56-07:00 America/Los_Angeles - Remove spec isolation logic, this can be an external plugin Test-Stream 1.302014 2015-10-03 20:30:14-07:00 America/Los_Angeles - Another Delta.t fix Test-Stream 1.302013 2015-10-02 21:51:45-07:00 America/Los_Angeles - Fix Util.t for some Term::ReadKey versions Test-Stream 1.302012 2015-10-01 15:42:27-07:00 America/Los_Angeles - Remove reservations file - Documentation updates (add missing docs) - Fix output handle in subtest diagnostics - Better subtest diagnostics - Whitespace fixes - Better error handling in threads in the workflows - Better support real fork vs pseudo fork Test-Stream 1.302011 2015-09-30 21:05:57-07:00 America/Los_Angeles - Documentation updates, typo fixes - Be safer, and less verbose, when detecting term size - Fix isolation in the spec plugin in windows - Skip sync test on windows (temporary measure) - Skip the hub.t fork check on windows (temporary measure) - Add some debugging to CanThread - Fix global event handling on platforms that do not use '/' for path - Fix Delta.t on systems with large memory addresses Test-Stream 1.302010 2015-09-29 22:23:28-07:00 America/Los_Angeles - Add spec plugin (with basic workflows modules) - Switch to plugin architecture, Test::Stream is just a loader - Add plugins (many of these were non-plugins before) AuthorTest BailOnFail Capabilities Capture Class Compare Context Core Defer DieOnFail Exception ExitSummary Grab IPC Intercept LoadPlugin Mock SRand SkipWithout Spec Subtest TAP UTF8 Warnings - CanFork is now a plugin - CanThread is now a plugin - Subtest stack fallback fix - Better Compare library - Documentation is fleshed out and mostly complete - Unit testing coverage is now satisfactory - Better detection of broken threads on 5.10.0 - Ability to set/change encoding - is_deeply() is now combined into is() - mostly_like() and like() are combined - DeepCheck library removed in favor of Compare library - deep checks now render a table - Test directory restructuring - Mocking library - Workflow library - Fix typos - Fix a GC destruction issue (b3a96db) Test-Stream 1.302009 2015-07-03 21:16:08-07:00 America/Los_Angeles - Fix MANIFEST.SKIP so tests are not skipped - Change import aliasing syntax to match prior art - Fix bug in does_ok - Documentation updates Test-Stream 1.302008 2015-06-27 15:21:55-07:00 America/Los_Angeles - Fix 2 bugs with threading on 5.8.x - Fix a diag rendering bug with subtests Test-Stream 1.302007 2015-06-24 08:03:38-07:00 America/Los_Angeles - Add CanThread and CanFork libraries - Remove prefix when subtests are buffered - Fix bug where Exporter might remove other tools exports - Fix bug in unmunge and unlisten - Add helper for specifying a context in which to run - Add causes_fail method for events - Fix rendering bug in subtest diags - Fix bug where IPC abort would fail to set exit code - Remove XS support code - Fix bug when threads are auto-joined Test-Stream 1.302006 2015-06-18 09:53:04-07:00 America/Los_Angeles - MANIFEST.SKIP fix - Remove files accidentally included in the last dist Test-Stream 1.302005 2015-06-18 09:37:38-07:00 America/Los_Angeles - Remove broken test script Test-Stream 1.302004 2015-06-17 08:32:31-07:00 America/Los_Angeles - Add Support for XS - Improve release_pp with refcount from internals Test-Stream 1.302003 2015-06-06 21:44:42-07:00 America/Los_Angeles - Documentation added - Make IPC::Files safe in cleanup Test-Stream 1.302002 2015-06-06 14:06:57-07:00 America/Los_Angeles - Fix Win32 support Test-Stream 1.302001 2015-06-05 22:40:57-07:00 America/Los_Angeles - Initial Version Test2-Suite 0.000163 2024-06-05 08:11:27-07:00 America/Los_Angeles - Documentation fixes Test2-Suite 0.000162 2024-04-25 14:57:23+01:00 Europe/Lisbon - Fix #292 and #270 Test2-Suite 0.000161 2024-04-25 12:05:32+01:00 Europe/Lisbon - Fix #289: some checks could leak across array bounds - Fix #285: Mocking around missing symbols Test2-Suite 0.000160 2024-04-25 11:18:36+01:00 Europe/Lisbon - Fix #291: done_testing under AsyncSubtest does not make sense - Fix #275: prototypes for around/after/before - Fix #288: Merge PR for #275 - Fix #290: Extra docs for srand Test2-Suite 0.000159 2023-10-25 14:09:23-07:00 America/Los_Angeles - Document that diag() intentionally returns false, and add a `return 0` Test2-Suite 0.000158 2023-10-22 22:05:42-07:00 America/Los_Angeles - Mark Workflow-Acceptance.t as AUTHOR_TESTING Test2-Suite 0.000157 2023-10-22 21:26:49-07:00 America/Los_Angeles - Fix #280: Document --no_srand option in Test2::V0 - Fix #276: Document bool() import in Test2::V0 - Fix #279: Merged fix for VMS test issues - Fix #277: Merged POD tweaks Test2-Suite 0.000156 2023-09-13 15:11:52-07:00 America/Los_Angeles - Fix typo in POD for Test2::Util::Importer Test2-Suite 0.000155 2023-04-28 08:28:42-07:00 America/Los_Angeles - Fix #247 - Fix changes file Test2-Suite 0.000154 2023-04-28 05:57:58-07:00 America/Los_Angeles - Fix 00-report.t Test2-Suite 0.000153 2023-04-27 15:27:32-07:00 America/Los_Angeles - Fix broken call to plugins Test2-Suite 0.000152 2023-04-27 02:52:44-07:00 America/Los_Angeles - Inline Importer.pm for core support Test2-Suite 0.000151 2023-04-27 02:35:37-07:00 America/Los_Angeles - The following are all in hopes of getting Test2:Suite into core. - Make Module::Pluggable optional - Inline Scope::Guard - Inline Sub::Info - Do not recommend Sub::Name Test2-Suite 0.000150 2023-03-21 08:25:21-07:00 America/Los_Angeles - Do not index Devel::MAT::Dumper Test2-Suite 0.000149 2023-03-21 06:44:50-07:00 America/Los_Angeles - Fix warning when Devel::MAT::Dumper is installed and -w is used Test2-Suite 0.000148 2023-03-05 14:59:45-08:00 America/Los_Angeles - Fixes for refcount stuff Test2-Suite 0.000147 2023-03-04 11:42:59-08:00 America/Los_Angeles - Add refcount tools, and include in ::V0 Test2-Suite 0.000146 2023-03-04 11:08:10-08:00 America/Los_Angeles - Add T2_AUTO_DUMP and T2_AUTO_DEPARSE env vars Test2-Suite 0.000145 2022-03-04 15:10:09-08:00 America/Los_Angeles - Fix subtest times to be hi-res Test2-Suite 0.000144 2021-12-03 13:17:19-08:00 America/Los_Angeles - Add void context warning for dies and lives Test2-Suite 0.000143 2021-12-01 11:20:03-08:00 America/Los_Angeles - Add stringification option for custom compare checks Test2-Suite 0.000142 2021-11-15 14:06:34-08:00 America/Los_Angeles - Fix deprecation diagnostics - Fix older perls by removing //= Test2-Suite 0.000141 2021-07-26 12:15:34-07:00 America/Los_Angeles - Add start and stop stamps to async subtest Test2-Suite 0.000140 2021-05-12 08:08:17-07:00 America/Los_Angeles - Add L() "length" quick check for comparisons Test2-Suite 0.000139 2020-12-15 19:48:07-08:00 America/Los_Angeles - Merge PR to add ISA checks - Fix Manual module that was missing package/return true Test2-Suite 0.000138 2020-10-21 19:46:07-07:00 America/Los_Angeles - Merge doc fix from PR - Merge strict fix for test Test2-Suite 0.000137 2020-10-21 18:22:07-07:00 America/Los_Angeles - Test new syntax `use Test2::Plugin::SRand seed => $seed;` - Update GitHub workflow with deprecated add-path Test2-Suite 0.000136 2020-10-05 22:05:24-07:00 America/Los_Angeles - Fix typo Test2::Builder -> Test::Builder - Improve import logic for SRand - Other misc typo fixes Test2-Suite 0.000135 2020-08-16 21:44:24-07:00 America/Los_Angeles - No changes since last trial Test2-Suite 0.000134 2020-08-15 13:11:30-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix 5.8 support Test2-Suite 0.000133 2020-08-14 21:59:19-07:00 America/Los_Angeles (TRIAL RELEASE) - Add summary of missing/extra elements in compare diagnostics Test2-Suite 0.000132 2020-08-06 18:10:48-07:00 America/Los_Angeles - Fix min Test2 version Test2-Suite 0.000131 2020-08-05 21:45:59-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix the grabber tool to inherit Test::Builder $TODO functionality Test2-Suite 0.000130 2020-05-30 11:11:54-07:00 America/Los_Angeles - Many documentation fixes Test2-Suite 0.000129 2020-01-31 08:33:46-08:00 America/Los_Angeles - José Joaquín Atria Improve error handling of mock->override with AUTOLOADed methods Test2-Suite 0.000128 2020-01-30 08:45:43-08:00 America/Los_Angeles - Nicolas R Import option to skip utf8 import - Victoria Mihell-Hale Correct POD for Test2/Tools/Mock.pm's mocked() method - Victoria Mihell-Hale Fix miscellaneous typos in Test2(/Tools)/Mock.pm POD - Nicolas R Add GitHub actions - Daniel Mita Fix PKG case for Test2::Tools::Target docs - Daniel Mita Document target change in V0 and Bundle::Extended - Daniel Mita Allow hashref to be used for Test2::Tools::Target Test2-Suite 0.000127 2019-10-30 21:25:29-07:00 America/Los_Angeles - Fix srand toggling Test2-Suite 0.000126 2019-08-28 12:44:59-07:00 America/Los_Angeles - Mention HUGE caveat in Test2::Plugin::Times - Make Test2::Util::Times::render_duration support 1 arg form Test2-Suite 0.000125 2019-08-19 10:40:20-07:00 America/Los_Angeles - Add harness_job_fields to Times plugin Test2-Suite 0.000124 2019-08-16 14:54:25-07:00 America/Los_Angeles - Make Times plugin use INFO facets for display Test2-Suite 0.000123 2019-08-16 13:21:29-07:00 America/Los_Angeles - Fix double-load bug on Plugin::Times Test2-Suite 0.000122 2019-05-18 08:21:20-07:00 America/Los_Angeles - Fix diag issues with ClassicCompare Test2-Suite 0.000121 2019-05-07 12:00:27-07:00 America/Los_Angeles - Tracking for mocked methods - Include raw table in facet data when compare fails Test2-Suite 0.000120 2019-04-26 05:19:18-07:00 America/Los_Angeles - Allow all_items inside bag Test2-Suite 0.000119 2019-03-16 15:17:33-07:00 America/Los_Angeles - Allow meta-checks in bag/array/hash (Thanks jjatria) Test2-Suite 0.000118 2019-01-18 13:44:06-08:00 America/Los_Angeles - Fix typo Test::Workflow -> Test2::Workflow #170 - Fix test broken by new Test-Simple #175 Test2-Suite 0.000117 2018-12-04 11:37:15-08:00 America/Los_Angeles - Remove test that belongs in another dist Test2-Suite 0.000116 2018-11-28 15:47:12-08:00 America/Los_Angeles - Add 'set' to mock tools - Fix 'overload' issue in deep check cycle detection. - Minor updates Test2-Suite 0.000115 2018-07-11 09:39:37-07:00 America/Los_Angeles - Fix warning on undefined note/diag - Improve an error message. Test2-Suite 0.000114 2018-04-19 08:39:56-07:00 America/Los_Angeles - Fix missing manual section Test2-Suite 0.000113 2018-04-19 08:03:42-07:00 America/Los_Angeles - Fix typo Test2-Suite 0.000112 2018-04-19 07:15:40-07:00 America/Los_Angeles - Switch spec to use the testing_done callback - Update copyright dates - Finish the Anatomy manual section - Finish the Tooling manual section Test2-Suite 0.000111 2018-03-14 12:37:45-07:00 America/Los_Angeles - No Changes since last trial Test2-Suite 0.000110 2018-03-13 13:36:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Allow events from unattached processes in AsyncSubtest Test2-Suite 0.000109 2018-03-12 13:20:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Add AsyncSubtest retrieval to hubs Test2-Suite 0.000108 2018-03-11 12:51:56-07:00 America/Los_Angeles - No changes since last release Test2-Suite 0.000107 2018-03-09 15:43:30-08:00 America/Los_Angeles (TRIAL RELEASE) - Add rounded() and within() wrappers for approximate comparisons Test2-Suite 0.000106 2018-03-06 13:10:55-08:00 America/Los_Angeles - No changes since trial Test2-Suite 0.000105 2018-03-06 09:13:36-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix nesting bug in Test2::Workflow Test2-Suite 0.000104 2018-03-05 09:27:44-08:00 America/Los_Angeles - Add Data::Dumper to dep list (#154) Test2-Suite 0.000103 2018-03-02 13:00:54-08:00 America/Los_Angeles (TRIAL RELEASE) - AsyncSubtest now works with UUIDs and adds other proper meta-data Test2-Suite 0.000102 2018-03-02 09:45:27-08:00 America/Los_Angeles - No Changes since last trial Test2-Suite 0.000101 2018-02-21 16:27:18-08:00 America/Los_Angeles (TRIAL RELEASE) - Add much needed verbosity to 'You must attach to an AsyncSubtest ...' errors - Documentation updates Test2-Suite 0.000100 2018-02-13 21:41:30-08:00 America/Los_Angeles - No changes from last TRIAL Test2-Suite 0.000099 2018-02-06 12:53:16-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix AsyncSubtest plan to be at the right nesting, and buffered Test2-Suite 0.000098 2018-02-06 12:05:28-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix AsyncSubtest main event buffered/nesting values - Fix bug where AsyncSub test vanishes with no error when finished after its parent ends. Test2-Suite 0.000097 2017-12-10 20:23:21-08:00 America/Los_Angeles - Documentation fixes Test2-Suite 0.000096 2017-12-09 10:13:21-08:00 America/Los_Angeles - No changes since last trial Test2-Suite 0.000095 2017-12-08 14:14:16-08:00 America/Los_Angeles (TRIAL RELEASE) - Discoruage use of fragile thread features (rarely used) - Skip fragile/discrouaged tests outside author testing. - Document the above, and an env var to activate tests when desired Test2-Suite 0.000094 2017-11-29 18:51:54-08:00 America/Los_Angeles - No Changes since last trial Test2-Suite 0.000093 2017-11-28 20:21:09-08:00 America/Los_Angeles (TRIAL RELEASE) - Minor test changes for thread safety Test2-Suite 0.000092 2017-11-28 10:17:37-08:00 America/Los_Angeles - No changes since last trial Test2-Suite 0.000091 2017-11-27 14:17:00-08:00 America/Los_Angeles (TRIAL RELEASE) - Remove experiments from last several trials Test2-Suite 0.000090 2017-11-26 18:52:06-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix potential infinite hang in temp debugging Test2-Suite 0.000089 2017-11-26 11:16:15-08:00 America/Los_Angeles (TRIAL RELEASE) - More debugging Test2-Suite 0.000088 2017-11-26 10:18:46-08:00 America/Los_Angeles (TRIAL RELEASE) - Add some debugging and an alternate IPC driver - Temporary, this will be reverted Test2-Suite 0.000087 2017-11-24 12:28:27-08:00 America/Los_Angeles (TRIAL RELEASE) - Merge in Test2::Workflow - Merge in Test2::AsyncSubtest - Merge in Test2::Manual Test2-Suite 0.000086 2017-11-22 22:15:41-08:00 America/Los_Angeles (TRIAL RELEASE) - Make an AUTHOR_TEST require 5.20 Test2-Suite 0.000085 2017-11-22 22:05:11-08:00 America/Los_Angeles (TRIAL RELEASE) - Ensure that objects are not used in Boolean contexts, second attempt. (djerius) Test2-Suite 0.000084 2017-11-18 16:17:29-08:00 America/Los_Angeles - Add Test2::Tools::Tester Test2-Suite 0.000083 2017-10-25 08:12:18-07:00 America/Los_Angeles - Mark a float tests TODO until the PR author can fix it Test2-Suite 0.000082 2017-10-20 07:11:08-07:00 America/Los_Angeles - No Changes since last trial Test2-Suite 0.000081 2017-10-19 09:09:14-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Compare::Float to handle floating point comparison issues with representation error. - Add float() to Test2::Utils::Compare and import Test2::Compare::Float - Import and Export Test2::Utils::Compare::float in Test2::V0 - Documentation fixes - Better 5.10.0/utf8 fix - VSTRING comparisons - Bag compare now handles duplicates better Test2-Suite 0.000080 2017-10-15 10:13:30-07:00 America/Los_Angeles - No changes since last trial Test2-Suite 0.000079 2017-10-14 20:18:51-07:00 America/Los_Angeles (TRIAL RELEASE) - (Colin Newell) Fix UTF8 issue with perl 5.10.0 Test2-Suite 0.000078 2017-10-14 20:15:21-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix for TODO + new ok style Test2-Suite 0.000077 2017-09-12 07:49:16-07:00 America/Los_Angeles - No changes since last TRIAL release Test2-Suite 0.000076 2017-09-11 15:21:07-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Tools::GenTemp Test2-Suite 0.000075 2017-09-10 21:22:17-07:00 America/Los_Angeles - Add version to Test2::Event::Times Test2-Suite 0.000074 2017-08-31 20:37:47-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Event::Times - Fix some tests that were failing in yath Test2-Suite 0.000073 2017-08-30 23:11:28-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Plugin::Times Test2-Suite 0.000072 2017-06-17 21:48:14-07:00 America/Los_Angeles - No change since last trial Test2-Suite 0.000071 2017-06-10 13:40:27-07:00 America/Los_Angeles (TRIAL RELEASE) - Introduce Test2::V# bundles - Deprecate Test2::Bundle::Extended - Test2::V0 added - Fix Test2::Mock doesn't accept non-ref values (Mike Raynham) - Fix isa_ok overload issue (Mike Raynham) Test2-Suite 0.000070 2017-03-19 13:34:25-07:00 America/Los_Angeles - Revert Boolean overload fixes from djerius until they can be fixed - Do not mention Term::ReadKey in docs - Add Term::Size::Any to test report Test2-Suite 0.000069 2017-03-16 20:57:43-07:00 America/Los_Angeles - No changes from trial Test2-Suite 0.000068 2017-03-08 20:22:23-08:00 America/Los_Angeles (TRIAL RELEASE) - Set the term size for all tests that use tables - Boolean overload fixes from djerius Test2-Suite 0.000067 2017-01-03 19:41:52-08:00 America/Los_Angeles - No changes Test2-Suite 0.000066 2016-12-23 15:16:18-08:00 America/Los_Angeles (TRIAL RELEASE) - Move sub_info to Sub::Info Test2-Suite 0.000065 2016-12-19 19:46:47-08:00 America/Los_Angeles - AUTHOR_TESTING a fragile test Test2-Suite 0.000064 2016-12-19 11:56:28-08:00 America/Los_Angeles (TRIAL RELEASE) - Move Test2::Util::Table to Term::Table Test2-Suite 0.000063 2016-12-17 12:11:39-08:00 America/Los_Angeles - No notable changes since the last trial release. Test2-Suite 0.000062 2016-12-03 14:03:44-08:00 America/Los_Angeles (TRIAL RELEASE) - An event without a trace object throw would an exception when using Test2::Compare::Event and the comparison failed - Fix tests for small terminals (#106) - Enhance the table library - UTF8 plugin does not set STDERR/STDOUT Test2-Suite 0.000061 2016-11-26 12:39:14-08:00 America/Los_Angeles - Fix mocked objects so that they respond properly to ->can when using AUTOLOAD. - Fix some meta-files - Small build improvements - Minor fixes Test2-Suite 0.000060 2016-09-25 12:38:43-07:00 America/Los_Angeles - Fix some docs - Fix defer.t to work in windows - Fix stack stomping bug triggered by certain Term::Readkey conditions Test2-Suite 0.000059 2016-09-15 13:00:03-07:00 America/Los_Angeles (TRIAL RELEASE) - Create Test2::Compare::Negatable - Add bool() for deep comparisons - Implicit end() for checks inside is() - Add try_ok to Tools/Exception - Export convert() in Test2::Compare - Make convert more flexible - Document how to write a compare tool with custom behavior Test2-Suite 0.000058 2016-08-13 13:06:10-07:00 America/Los_Angeles - No changes from last trial Test2-Suite 0.000057 2016-08-10 22:13:39-07:00 America/Los_Angeles (TRIAL RELEASE) - Add contact info to docs Test2-Suite 0.000056 2016-08-09 14:09:17-07:00 America/Los_Angeles (TRIAL RELEASE) - Make sure Test2::Compare::convert loads deps Test2-Suite 0.000055 2016-07-30 13:18:13-07:00 America/Los_Angeles - Spelling fix from Debian (Thanks gregor herrmann) - Fix \d -> [0-9] in several places (Thanks Mark F.) Test2-Suite 0.000054 2016-07-28 07:10:34-07:00 America/Los_Angeles - No changes from last trial Test2-Suite 0.000053 2016-07-22 22:51:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Make bag check fail when given an empty array - Clean up bag diagnostics Test2-Suite 0.000052 2016-07-18 09:07:25-07:00 America/Los_Angeles - No changes from last TRIAL Test2-Suite 0.000051 2016-07-13 18:00:17-07:00 America/Los_Angeles (TRIAL RELEASE) - Switch Extended bundle to use Importer - Add meta_check as alias for meta Test2-Suite 0.000050 2016-07-09 16:58:59-07:00 America/Los_Angeles - No Changes since trial Test2-Suite 0.000049 2016-07-07 22:02:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Doc fixes - Add U() quick check to Test2::Tools::Compare Test2-Suite 0.000048 2016-07-02 22:08:10-07:00 America/Los_Angeles - No changes from last trial Test2-Suite 0.000047 2016-07-01 18:09:26-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix global destruction warning - Minor test fix to keep 5.8 working Test2-Suite 0.000046 2016-07-01 17:31:23-07:00 America/Los_Angeles (TRIAL RELEASE) - ref-ref's can be used in deep comparisons - Fix mocking to override a base class's method Test2-Suite 0.000045 2016-07-01 09:30:09-07:00 America/Los_Angeles - Spelling and POD fixes Test2-Suite 0.000044 2016-06-29 15:48:33-07:00 America/Los_Angeles (TRIAL RELEASE) - Add DF() shortcut (JBerger) Test2-Suite 0.000043 2016-06-28 06:23:46-07:00 America/Los_Angeles (TRIAL RELEASE) - Restructure Delta.pm to try and solve read-only problem Test2-Suite 0.000042 2016-06-27 21:37:22-07:00 America/Los_Angeles - Change Encoding.t to spit out debug message without failing Test2-Suite 0.000041 2016-06-27 09:00:46-07:00 America/Los_Angeles - Add perltidy rc to dist - Documentation fixes (Thanks petdance) - revert "Attempt a fix to Delta #29" Test2-Suite 0.000039 2016-06-25 13:44:03-07:00 America/Los_Angeles (TRIAL RELEASE) - Stop leaking temp files - clean up STDERR - Fix #28 Test2-Suite 0.000038 2016-06-25 13:20:07-07:00 America/Los_Angeles - No Changes from last TRIAL release Test2-Suite 0.000037 2016-06-24 14:03:52-07:00 America/Los_Angeles (TRIAL RELEASE) - Add all_keys() to Compare tools - add all_vals() to Compare tools - add all_items() to Compare tools - Fix in_set(DNE) (#10) - Add E() - Proper line reporting for shortcuts. Test2-Suite 0.000036 2016-06-24 05:58:51-07:00 America/Los_Angeles - Better comments in SRAND (#7) Test2-Suite 0.000035 2016-06-23 14:48:54-07:00 America/Los_Angeles (TRIAL RELEASE) - Make it possible to provide a name to isa_ok, can_ok, and DOES_ok - Add some regression tests for previous fixes - Allow 'tests' and 'skip_all' prefixes support to plan() #25 Test2-Suite 0.000034 2016-06-22 11:30:00-07:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version Test2-Suite 0.000033 2016-06-22 08:41:22-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix ClassicCompare to load deps (#23) Test2-Suite 0.000032 2016-06-17 06:58:17-07:00 America/Los_Angeles - Add 'bag' comparison (dakkar) - Add 'call_list()' for DSL (dakkar) - Add 'call_hash()' for DSL (dakkar) Test2-Suite 0.000031 2016-06-15 21:32:05-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix TODO to use pre-filters Test2-Suite 0.000030 2016-05-09 07:55:17-07:00 America/Los_Angeles - Doc Changes Test2-Suite 0.000029 2016-04-30 15:17:01-07:00 America/Los_Angeles - Doc updates from jkeroes - Doc updates from stevieb9 - SRand now works without harness - Fix emails Test2-Suite 0.000028 2016-04-15 14:32:30-07:00 America/Los_Angeles - Add Tools/Event gen_event() - Add Tools/Event to Extended bundle Test2-Suite 0.000027 2016-04-13 20:22:17-07:00 America/Los_Angeles - Make some tests ignore custom formatters Test2-Suite 0.000026 2016-04-05 11:11:35-07:00 America/Los_Angeles - Add OrderedSubset compare tools - Use OrderedSubset compare tool in subtest tests. - Bump minimumTest2 version Test2-Suite 0.000025 2016-04-03 15:39:59-07:00 America/Los_Angeles - Allow column aliasing in Deltas (jkeroes) - Bump required Test2 version Test2-Suite 0.000024 2016-03-20 13:40:06-07:00 America/Los_Angeles - Add back missing README and README.md files - Documentation fixes - No logic/code changes Test2-Suite 0.000023 2016-03-17 23:02:50-07:00 America/Los_Angeles - Fix Changes file - Fix bug where SRand plugin comment could appear in subtest Test2-Suite 0.000022 2016-03-07 12:18:25-08:00 America/Los_Angeles - Ability to disable subtest skip_all flow control Test2-Suite 0.000021 2016-03-06 20:24:46-08:00 America/Los_Angeles - Bump minimum Test2 version - Add version to all modules - Minor doc fixes - No logic changes Test2-Suite 0.000020 2016-02-05 09:32:52-08:00 America/Los_Angeles - Fix typo that made mock tool look in the wrong place for handlers Test2-Suite 0.000019 2016-01-28 21:28:37-08:00 America/Los_Angeles - Formally add the warning and exception tools - warning and exception tools added to the extended bundle Test2-Suite 0.000018 2016-01-12 16:09:44-08:00 America/Los_Angeles - Add grab tool - Fix documentation Test2-Suite 0.000017 2016-01-12 05:54:43-08:00 America/Los_Angeles - Fix poorly written test Test2-Suite 0.000016 2016-01-11 15:18:04-08:00 America/Los_Angeles - Add diagnostics test report - Fix tests on older perls Test2-Suite 0.000015 2016-01-10 22:50:54-08:00 America/Los_Angeles - Fix documentation problem Test2-Suite 0.000014 2016-01-10 22:42:56-08:00 America/Los_Angeles - Initial conversion from Test::Stream Test2-Harness 0.000018 2017-01-31 21:33:34-08:00 America/Los_Angeles - Use Sub::Info to silence a warning Test2-Harness 0.000017 2016-07-31 21:24:00-07:00 America/Los_Angeles - Fix acceptance5.t to not assume fork is used. Test2-Harness 0.000016 2016-07-29 12:37:29-07:00 America/Los_Angeles - Require newer Importer.pm for :ALL tag Test2-Harness 0.000015 2016-07-28 07:07:37-07:00 America/Los_Angeles - Run blocks when done_testing is missing (#3) - Add spec_defaults() Test2-Harness 0.000014 2016-07-02 22:11:29-07:00 America/Los_Angeles - No Changes from last trial Test2-Harness 0.000013 2016-07-01 17:33:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Do not apply mock defined on root action. Test2-Harness 0.000012 2016-06-24 06:01:16-07:00 America/Los_Angeles - No changes since last trial Test2-Harness 0.000011 2016-06-22 11:32:58-07:00 America/Los_Angeles (TRIAL RELEASE) - Require newer Test2::AsyncSubtest for bugfixes Test2-Harness 0.000010 2016-06-22 09:16:07-07:00 America/Los_Angeles - Fix for (and require) Test2-Suite 0.000032 (#2) - Better TODO handling Test2-Harness 0.000009 2016-05-31 07:18:50-07:00 America/Los_Angeles - Require perl 5.10 Test2-Harness 0.000008 2016-05-30 07:38:55-07:00 America/Los_Angeles - Require newer Test2::AsyncSubtest Test2-Harness 0.000007 2016-05-30 06:58:17-07:00 America/Los_Angeles - Complete rewrite Test2-Harness 0.000006 2016-02-05 15:45:57-08:00 America/Los_Angeles - Prep for a new Trace::Mask version Test2-Harness 0.000005 2016-02-05 11:56:11-08:00 America/Los_Angeles - Bump minimum Test2::Suite version (fixes issue found in windows tests) Test2-Harness 0.000004 2016-02-04 21:48:07-08:00 America/Los_Angeles - Add Spec bundle Test2-Harness 0.000003 2016-02-04 10:46:41-08:00 America/Los_Angeles - Fix test that needs to be conditional - Fix constant in NoIso Test2-Harness 0.000002 2016-02-03 08:12:34-08:00 America/Los_Angeles - Major overhaul - Add isolation runners - Lots of fixes - Masking traces properly - Better filtering Test2-Harness 0.000001 2016-01-18 10:54:17-08:00 America/Los_Angeles - Initial conversion from Test::Stream Test2-AsyncSubtest 0.000020 2017-09-10 21:23:49-07:00 America/Los_Angeles - No Changes from last release Test2-AsyncSubtest 0.000019 2017-09-08 12:21:34-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix support for formatters that show buffered events Test2-AsyncSubtest 0.000018 2016-06-24 06:00:04-07:00 America/Los_Angeles - No changes since last trial Test2-AsyncSubtest 0.000017 2016-06-22 11:32:15-07:00 America/Los_Angeles (TRIAL RELEASE) - Make our hub inherit pre_filters properly Test2-AsyncSubtest 0.000016 2016-05-30 07:36:39-07:00 America/Los_Angeles - Fix bug where subtest results were repeated Test2-AsyncSubtest 0.000015 2016-05-09 08:03:51-07:00 America/Los_Angeles Test2-AsyncSubtest 0.000014 2016-04-14 09:40:01-07:00 America/Los_Angeles - Support custom formatters - Add subtest info to events Test2-AsyncSubtest 0.000013 2016-03-20 13:47:39-07:00 America/Los_Angeles - Add subtest name to pending warning Test2-AsyncSubtest 0.000012 2016-03-18 17:52:46-07:00 America/Los_Angeles - Fix trigger conditions for pending warning Test2-AsyncSubtest 0.000011 2016-03-18 08:12:05-07:00 America/Los_Angeles - Inherit listeners and filters (make TODO work) - Add 'todo' option to finish() Test2-AsyncSubtest 0.000010 2016-03-17 23:21:58-07:00 America/Los_Angeles - Fix bug in 'skip' option when nesting Test2-AsyncSubtest 0.000009 2016-03-17 11:51:08-07:00 America/Los_Angeles - Add 'skip' option for finish() Test2-AsyncSubtest 0.000008 2016-03-10 16:53:55-08:00 America/Los_Angeles - Add 'silent', 'no_plan' and 'collapse' options for finish() Test2-AsyncSubtest 0.000007 2016-03-09 10:07:53-08:00 America/Los_Angeles - Fix tests for some perl+thread combos Test2-AsyncSubtest 0.000006 2016-03-08 08:47:22-08:00 America/Los_Angeles - Fix #6, make tools more argument aware Test2-AsyncSubtest 0.000005 2016-03-07 12:21:28-08:00 America/Los_Angeles - Add ability to bypass subtest skip_all flow control Test2-AsyncSubtest 0.000004 2016-03-06 20:19:02-08:00 America/Los_Angeles - Require newer Test2 - Add extended skip_all tests - Add version to all modules (autarch) Test2-AsyncSubtest 0.000003 2016-03-05 17:33:15-08:00 America/Los_Angeles - Update for min threads version Test2-AsyncSubtest 0.000002 2016-03-02 13:49:22-08:00 America/Los_Angeles - Complete Rewrite Test2-AsyncSubtest 0.000001 2016-02-23 15:35:07-08:00 America/Los_Angeles - Initial Release MANIFEST100644001750001750 4153114772042322 15672 0ustar00exodistexodist000000000000Test-Simple-1.302210# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.032. Changes LICENSE MANIFEST META.json META.yml Makefile.PL README README.md appveyor.yml cpanfile examples/indent.pl examples/subtest.t examples/tools.pl examples/tools.t lib/Test/Builder.pm lib/Test/Builder/Formatter.pm lib/Test/Builder/Module.pm lib/Test/Builder/Tester.pm lib/Test/Builder/Tester/Color.pm lib/Test/Builder/TodoDiag.pm lib/Test/More.pm lib/Test/Simple.pm lib/Test/Tester.pm lib/Test/Tester/Capture.pm lib/Test/Tester/CaptureRunner.pm lib/Test/Tester/Delegate.pm lib/Test/Tutorial.pod lib/Test/use/ok.pm lib/Test2.pm lib/Test2/API.pm lib/Test2/API/Breakage.pm lib/Test2/API/Context.pm lib/Test2/API/Instance.pm lib/Test2/API/InterceptResult.pm lib/Test2/API/InterceptResult/Event.pm lib/Test2/API/InterceptResult/Facet.pm lib/Test2/API/InterceptResult/Hub.pm lib/Test2/API/InterceptResult/Squasher.pm lib/Test2/API/Stack.pm lib/Test2/AsyncSubtest.pm lib/Test2/AsyncSubtest/Event/Attach.pm lib/Test2/AsyncSubtest/Event/Detach.pm lib/Test2/AsyncSubtest/Formatter.pm lib/Test2/AsyncSubtest/Hub.pm lib/Test2/Bundle.pm lib/Test2/Bundle/Extended.pm lib/Test2/Bundle/More.pm lib/Test2/Bundle/Simple.pm lib/Test2/Compare.pm lib/Test2/Compare/Array.pm lib/Test2/Compare/Bag.pm lib/Test2/Compare/Base.pm lib/Test2/Compare/Bool.pm lib/Test2/Compare/Custom.pm lib/Test2/Compare/DeepRef.pm lib/Test2/Compare/Delta.pm lib/Test2/Compare/Event.pm lib/Test2/Compare/EventMeta.pm lib/Test2/Compare/Float.pm lib/Test2/Compare/Hash.pm lib/Test2/Compare/Isa.pm lib/Test2/Compare/Meta.pm lib/Test2/Compare/Negatable.pm lib/Test2/Compare/Number.pm lib/Test2/Compare/Object.pm lib/Test2/Compare/OrderedSubset.pm lib/Test2/Compare/Pattern.pm lib/Test2/Compare/Ref.pm lib/Test2/Compare/Regex.pm lib/Test2/Compare/Scalar.pm lib/Test2/Compare/Set.pm lib/Test2/Compare/String.pm lib/Test2/Compare/Undef.pm lib/Test2/Compare/Wildcard.pm lib/Test2/Env.pm lib/Test2/Event.pm lib/Test2/Event/Bail.pm lib/Test2/Event/Diag.pm lib/Test2/Event/Encoding.pm lib/Test2/Event/Exception.pm lib/Test2/Event/Fail.pm lib/Test2/Event/Generic.pm lib/Test2/Event/Note.pm lib/Test2/Event/Ok.pm lib/Test2/Event/Pass.pm lib/Test2/Event/Plan.pm lib/Test2/Event/Skip.pm lib/Test2/Event/Subtest.pm lib/Test2/Event/TAP/Version.pm lib/Test2/Event/V2.pm lib/Test2/Event/Waiting.pm lib/Test2/EventFacet.pm lib/Test2/EventFacet/About.pm lib/Test2/EventFacet/Amnesty.pm lib/Test2/EventFacet/Assert.pm lib/Test2/EventFacet/Control.pm lib/Test2/EventFacet/Error.pm lib/Test2/EventFacet/Hub.pm lib/Test2/EventFacet/Info.pm lib/Test2/EventFacet/Info/Table.pm lib/Test2/EventFacet/Meta.pm lib/Test2/EventFacet/Parent.pm lib/Test2/EventFacet/Plan.pm lib/Test2/EventFacet/Render.pm lib/Test2/EventFacet/Trace.pm lib/Test2/Formatter.pm lib/Test2/Formatter/TAP.pm lib/Test2/Hub.pm lib/Test2/Hub/Interceptor.pm lib/Test2/Hub/Interceptor/Terminator.pm lib/Test2/Hub/Subtest.pm lib/Test2/IPC.pm lib/Test2/IPC/Driver.pm lib/Test2/IPC/Driver/Files.pm lib/Test2/Manual.pm lib/Test2/Manual/Anatomy.pm lib/Test2/Manual/Anatomy/API.pm lib/Test2/Manual/Anatomy/Context.pm lib/Test2/Manual/Anatomy/EndToEnd.pm lib/Test2/Manual/Anatomy/Event.pm lib/Test2/Manual/Anatomy/Hubs.pm lib/Test2/Manual/Anatomy/IPC.pm lib/Test2/Manual/Anatomy/Utilities.pm lib/Test2/Manual/Concurrency.pm lib/Test2/Manual/Contributing.pm lib/Test2/Manual/Testing.pm lib/Test2/Manual/Testing/Introduction.pm lib/Test2/Manual/Testing/Migrating.pm lib/Test2/Manual/Testing/Planning.pm lib/Test2/Manual/Testing/Todo.pm lib/Test2/Manual/Tooling.pm lib/Test2/Manual/Tooling/FirstTool.pm lib/Test2/Manual/Tooling/Formatter.pm lib/Test2/Manual/Tooling/Nesting.pm lib/Test2/Manual/Tooling/Plugin/TestExit.pm lib/Test2/Manual/Tooling/Plugin/TestingDone.pm lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm lib/Test2/Manual/Tooling/Subtest.pm lib/Test2/Manual/Tooling/TestBuilder.pm lib/Test2/Manual/Tooling/Testing.pm lib/Test2/Mock.pm lib/Test2/Plugin.pm lib/Test2/Plugin/BailOnFail.pm lib/Test2/Plugin/DieOnFail.pm lib/Test2/Plugin/ExitSummary.pm lib/Test2/Plugin/SRand.pm lib/Test2/Plugin/Times.pm lib/Test2/Plugin/UTF8.pm lib/Test2/Require.pm lib/Test2/Require/AuthorTesting.pm lib/Test2/Require/AutomatedTesting.pm lib/Test2/Require/EnvVar.pm lib/Test2/Require/ExtendedTesting.pm lib/Test2/Require/Fork.pm lib/Test2/Require/Module.pm lib/Test2/Require/NonInteractiveTesting.pm lib/Test2/Require/Perl.pm lib/Test2/Require/RealFork.pm lib/Test2/Require/ReleaseTesting.pm lib/Test2/Require/Threads.pm lib/Test2/Suite.pm lib/Test2/Todo.pm lib/Test2/Tools.pm lib/Test2/Tools/AsyncSubtest.pm lib/Test2/Tools/Basic.pm lib/Test2/Tools/Class.pm lib/Test2/Tools/ClassicCompare.pm lib/Test2/Tools/Compare.pm lib/Test2/Tools/Defer.pm lib/Test2/Tools/Encoding.pm lib/Test2/Tools/Event.pm lib/Test2/Tools/Exception.pm lib/Test2/Tools/Exports.pm lib/Test2/Tools/GenTemp.pm lib/Test2/Tools/Grab.pm lib/Test2/Tools/Mock.pm lib/Test2/Tools/Ref.pm lib/Test2/Tools/Refcount.pm lib/Test2/Tools/Spec.pm lib/Test2/Tools/Subtest.pm lib/Test2/Tools/Target.pm lib/Test2/Tools/Tester.pm lib/Test2/Tools/Tiny.pm lib/Test2/Tools/Warnings.pm lib/Test2/Transition.pod lib/Test2/Util.pm lib/Test2/Util/ExternalMeta.pm lib/Test2/Util/Facets2Legacy.pm lib/Test2/Util/Grabber.pm lib/Test2/Util/Guard.pm lib/Test2/Util/HashBase.pm lib/Test2/Util/Importer.pm lib/Test2/Util/Ref.pm lib/Test2/Util/Sig.pm lib/Test2/Util/Stash.pm lib/Test2/Util/Sub.pm lib/Test2/Util/Table.pm lib/Test2/Util/Table/Cell.pm lib/Test2/Util/Table/LineBreak.pm lib/Test2/Util/Term.pm lib/Test2/Util/Times.pm lib/Test2/Util/Trace.pm lib/Test2/V0.pm lib/Test2/Workflow.pm lib/Test2/Workflow/BlockBase.pm lib/Test2/Workflow/Build.pm lib/Test2/Workflow/Runner.pm lib/Test2/Workflow/Task.pm lib/Test2/Workflow/Task/Action.pm lib/Test2/Workflow/Task/Group.pm lib/ok.pm perltidyrc t/00-report.t t/00compile.t t/HashBase.t t/Legacy/00test_harness_check.t t/Legacy/01-basic.t t/Legacy/478-cmp_ok_hash.t t/Legacy/BEGIN_require_ok.t t/Legacy/BEGIN_use_ok.t t/Legacy/Bugs/600.t t/Legacy/Bugs/629.t t/Legacy/Builder/Builder.t t/Legacy/Builder/carp.t t/Legacy/Builder/create.t t/Legacy/Builder/current_test.t t/Legacy/Builder/current_test_without_plan.t t/Legacy/Builder/details.t t/Legacy/Builder/done_testing.t t/Legacy/Builder/done_testing_double.t t/Legacy/Builder/done_testing_plan_mismatch.t t/Legacy/Builder/done_testing_with_no_plan.t t/Legacy/Builder/done_testing_with_number.t t/Legacy/Builder/done_testing_with_plan.t t/Legacy/Builder/fork_with_new_stdout.t t/Legacy/Builder/has_plan.t t/Legacy/Builder/has_plan2.t t/Legacy/Builder/is_fh.t t/Legacy/Builder/is_passing.t t/Legacy/Builder/maybe_regex.t t/Legacy/Builder/no_diag.t t/Legacy/Builder/no_ending.t t/Legacy/Builder/no_header.t t/Legacy/Builder/no_plan_at_all.t t/Legacy/Builder/ok_obj.t t/Legacy/Builder/output.t t/Legacy/Builder/reset.t t/Legacy/Builder/reset_outputs.t t/Legacy/Builder/try.t t/Legacy/More.t t/Legacy/Regression/637.t t/Legacy/Regression/683_thread_todo.t t/Legacy/Regression/6_cmp_ok.t t/Legacy/Regression/736_use_ok.t t/Legacy/Regression/789-read-only.t t/Legacy/Regression/870-experimental-warnings.t t/Legacy/Regression/is_capture.t t/Legacy/Simple/load.t t/Legacy/Test2/Subtest.t t/Legacy/Tester/tbt_01basic.t t/Legacy/Tester/tbt_02fhrestore.t t/Legacy/Tester/tbt_03die.t t/Legacy/Tester/tbt_04line_num.t t/Legacy/Tester/tbt_05faildiag.t t/Legacy/Tester/tbt_06errormess.t t/Legacy/Tester/tbt_07args.t t/Legacy/Tester/tbt_08subtest.t t/Legacy/Tester/tbt_09do.t t/Legacy/Tester/tbt_09do_script.pl t/Legacy/auto.t t/Legacy/bad_plan.t t/Legacy/bail_out.t t/Legacy/buffer.t t/Legacy/c_flag.t t/Legacy/capture.t t/Legacy/check_tests.t t/Legacy/circular_data.t t/Legacy/cmp_ok.t t/Legacy/depth.t t/Legacy/diag.t t/Legacy/died.t t/Legacy/dont_overwrite_die_handler.t t/Legacy/eq_set.t t/Legacy/exit.t t/Legacy/explain.t t/Legacy/explain_err_vars.t t/Legacy/extra.t t/Legacy/extra_one.t t/Legacy/fail-like.t t/Legacy/fail-more.t t/Legacy/fail.t t/Legacy/fail_one.t t/Legacy/filehandles.t t/Legacy/fork.t t/Legacy/harness_active.t t/Legacy/import.t t/Legacy/is_deeply_dne_bug.t t/Legacy/is_deeply_fail.t t/Legacy/is_deeply_with_threads.t t/Legacy/missing.t t/Legacy/new_ok.t t/Legacy/no_log_results.t t/Legacy/no_plan.t t/Legacy/no_tests.t t/Legacy/note.t t/Legacy/overload.t t/Legacy/overload_threads.t t/Legacy/plan.t t/Legacy/plan_bad.t t/Legacy/plan_is_noplan.t t/Legacy/plan_no_plan.t t/Legacy/plan_shouldnt_import.t t/Legacy/plan_skip_all.t t/Legacy/require_ok.t t/Legacy/run_test.t t/Legacy/simple.t t/Legacy/skip.t t/Legacy/skipall.t t/Legacy/strays.t t/Legacy/subtest/args.t t/Legacy/subtest/bail_out.t t/Legacy/subtest/basic.t t/Legacy/subtest/callback.t t/Legacy/subtest/die.t t/Legacy/subtest/do.t t/Legacy/subtest/events.t t/Legacy/subtest/for_do_t.test t/Legacy/subtest/fork.t t/Legacy/subtest/implicit_done.t t/Legacy/subtest/line_numbers.t t/Legacy/subtest/predicate.t t/Legacy/subtest/singleton.t t/Legacy/subtest/threads.t t/Legacy/subtest/todo.t t/Legacy/subtest/wstat.t t/Legacy/tbm_doesnt_set_exported_to.t t/Legacy/thread_taint.t t/Legacy/threads.t t/Legacy/todo.t t/Legacy/undef.t t/Legacy/use_ok.t t/Legacy/useing.t t/Legacy/utf8.t t/Legacy/versions.t t/Legacy_And_Test2/builder_loaded_late.t t/Legacy_And_Test2/diag_event_on_ok.t t/Legacy_And_Test2/hidden_warnings.t t/Legacy_And_Test2/preload_diag_note.t t/Legacy_And_Test2/thread_init_warning.t t/Test2/acceptance/try_it_done_testing.t t/Test2/acceptance/try_it_fork.t t/Test2/acceptance/try_it_no_plan.t t/Test2/acceptance/try_it_plan.t t/Test2/acceptance/try_it_skip.t t/Test2/acceptance/try_it_threads.t t/Test2/acceptance/try_it_todo.t t/Test2/behavior/Formatter.t t/Test2/behavior/Subtest_buffer_formatter.t t/Test2/behavior/Subtest_callback.t t/Test2/behavior/Subtest_events.t t/Test2/behavior/Subtest_todo.t t/Test2/behavior/Taint.t t/Test2/behavior/disable_ipc_a.t t/Test2/behavior/disable_ipc_b.t t/Test2/behavior/disable_ipc_c.t t/Test2/behavior/disable_ipc_d.t t/Test2/behavior/err_var.t t/Test2/behavior/init_croak.t t/Test2/behavior/intercept.t t/Test2/behavior/ipc_wait_timeout.t t/Test2/behavior/nested_context_exception.t t/Test2/behavior/no_load_api.t t/Test2/behavior/run_subtest_inherit.t t/Test2/behavior/special_names.t t/Test2/behavior/subtest_bailout.t t/Test2/behavior/trace_signature.t t/Test2/behavior/trace_stamps.t t/Test2/behavior/uuid.t t/Test2/legacy/TAP.t t/Test2/modules/API.t t/Test2/modules/API/Breakage.t t/Test2/modules/API/Context.t t/Test2/modules/API/Instance.t t/Test2/modules/API/InterceptResult.t t/Test2/modules/API/InterceptResult/Event.t t/Test2/modules/API/InterceptResult/Squasher.t t/Test2/modules/API/Stack.t t/Test2/modules/Event.t t/Test2/modules/Event/Bail.t t/Test2/modules/Event/Diag.t t/Test2/modules/Event/Encoding.t t/Test2/modules/Event/Exception.t t/Test2/modules/Event/Fail.t t/Test2/modules/Event/Generic.t t/Test2/modules/Event/Note.t t/Test2/modules/Event/Ok.t t/Test2/modules/Event/Pass.t t/Test2/modules/Event/Plan.t t/Test2/modules/Event/Skip.t t/Test2/modules/Event/Subtest.t t/Test2/modules/Event/TAP/Version.t t/Test2/modules/Event/V2.t t/Test2/modules/Event/Waiting.t t/Test2/modules/EventFacet.t t/Test2/modules/EventFacet/About.t t/Test2/modules/EventFacet/Amnesty.t t/Test2/modules/EventFacet/Assert.t t/Test2/modules/EventFacet/Control.t t/Test2/modules/EventFacet/Error.t t/Test2/modules/EventFacet/Info.t t/Test2/modules/EventFacet/Meta.t t/Test2/modules/EventFacet/Parent.t t/Test2/modules/EventFacet/Plan.t t/Test2/modules/EventFacet/Trace.t t/Test2/modules/Formatter/TAP.t t/Test2/modules/Hub.t t/Test2/modules/Hub/Interceptor.t t/Test2/modules/Hub/Interceptor/Terminator.t t/Test2/modules/Hub/Subtest.t t/Test2/modules/IPC.t t/Test2/modules/IPC/Driver.t t/Test2/modules/IPC/Driver/Files.t t/Test2/modules/Tools/Tiny.t t/Test2/modules/Util.t t/Test2/modules/Util/ExternalMeta.t t/Test2/modules/Util/Facets2Legacy.t t/Test2/modules/Util/Trace.t t/Test2/regression/693_ipc_ordering.t t/Test2/regression/746-forking-subtest.t t/Test2/regression/gh_16.t t/Test2/regression/ipc_files_abort_exit.t t/acceptance/OO.t t/acceptance/Tools.t t/acceptance/Workflow-Acceptance.t t/acceptance/Workflow-Acceptance2.t t/acceptance/Workflow-Acceptance3.t t/acceptance/Workflow-Acceptance4.t t/acceptance/Workflow-Acceptance5.t t/acceptance/skip.t t/acceptance/spec.t t/behavior/Mocking.t t/behavior/async_trace.t t/behavior/filtering.t t/behavior/no_done_testing.t t/behavior/no_leaks_any.t t/behavior/no_leaks_no_fork.t t/behavior/no_leaks_no_iso.t t/behavior/no_leaks_no_threads.t t/behavior/simple.t t/lib/Dev/Null.pm t/lib/Dummy.pm t/lib/MyOverload.pm t/lib/MyTest.pm t/lib/MyTest/Target.pm t/lib/NoExporter.pm t/lib/SigDie.pm t/lib/SkipAll.pm t/lib/SmallTest.pm t/lib/Test/Builder/NoOutput.pm t/lib/Test/Simple/Catch.pm t/lib/Test/Simple/sample_tests/death.plx t/lib/Test/Simple/sample_tests/death_in_eval.plx t/lib/Test/Simple/sample_tests/death_with_handler.plx t/lib/Test/Simple/sample_tests/exit.plx t/lib/Test/Simple/sample_tests/extras.plx t/lib/Test/Simple/sample_tests/five_fail.plx t/lib/Test/Simple/sample_tests/last_minute_death.plx t/lib/Test/Simple/sample_tests/missing_done_testing.plx t/lib/Test/Simple/sample_tests/one_fail.plx t/lib/Test/Simple/sample_tests/one_fail_without_plan.plx t/lib/Test/Simple/sample_tests/pre_plan_death.plx t/lib/Test/Simple/sample_tests/require.plx t/lib/Test/Simple/sample_tests/success.plx t/lib/Test/Simple/sample_tests/too_few.plx t/lib/Test/Simple/sample_tests/too_few_fail.plx t/lib/Test/Simple/sample_tests/two_fail.plx t/lib/TieOut.pm t/load_manual.t t/modules/AsyncSubtest.t t/modules/AsyncSubtest/Event/Attach.t t/modules/AsyncSubtest/Event/Detach.t t/modules/AsyncSubtest/Hub.t t/modules/Bundle.t t/modules/Bundle/Extended.t t/modules/Bundle/More.t t/modules/Bundle/Simple.t t/modules/Compare.t t/modules/Compare/Array.t t/modules/Compare/Bag.t t/modules/Compare/Base.t t/modules/Compare/Bool.t t/modules/Compare/Custom.t t/modules/Compare/Delta.t t/modules/Compare/Event.t t/modules/Compare/EventMeta.t t/modules/Compare/Float.t t/modules/Compare/Hash.t t/modules/Compare/Isa.t t/modules/Compare/Meta.t t/modules/Compare/Number.t t/modules/Compare/Object.t t/modules/Compare/OrderedSubset.t t/modules/Compare/Pattern.t t/modules/Compare/Ref.t t/modules/Compare/Regex.t t/modules/Compare/Scalar.t t/modules/Compare/Set.t t/modules/Compare/String.t t/modules/Compare/Undef.t t/modules/Compare/Wildcard.t t/modules/Mock.t t/modules/Plugin.t t/modules/Plugin/BailOnFail.t t/modules/Plugin/DieOnFail.t t/modules/Plugin/ExitSummary.t t/modules/Plugin/SRand.t t/modules/Plugin/Times.t t/modules/Plugin/UTF8.t t/modules/Require.t t/modules/Require/AuthorTesting.t t/modules/Require/AutomatedTesting.t t/modules/Require/EnvVar.t t/modules/Require/ExtendedTesting.t t/modules/Require/Fork.t t/modules/Require/Module.t t/modules/Require/NonInteractiveTesting.t t/modules/Require/Perl.t t/modules/Require/RealFork.t t/modules/Require/ReleaseTesting.t t/modules/Require/Threads.t t/modules/Suite.t t/modules/Todo.t t/modules/Tools.t t/modules/Tools/AsyncSubtest.t t/modules/Tools/Basic.t t/modules/Tools/Class.t t/modules/Tools/ClassicCompare.t t/modules/Tools/ClassicCompare2.t t/modules/Tools/Compare.t t/modules/Tools/Defer.t t/modules/Tools/Encoding.t t/modules/Tools/Event.t t/modules/Tools/Exception.t t/modules/Tools/Exports.t t/modules/Tools/GenTemp.t t/modules/Tools/Grab.t t/modules/Tools/Mock.t t/modules/Tools/Ref.t t/modules/Tools/Spec.t t/modules/Tools/Subtest.t t/modules/Tools/Target.t t/modules/Tools/Test-Refcount/01count.t t/modules/Tools/Test-Refcount/02one.t t/modules/Tools/Test-Refcount/03weak.t t/modules/Tools/Test-Refcount/04reftypes.t t/modules/Tools/Tester.t t/modules/Tools/Warnings.t t/modules/Util/Grabber.t t/modules/Util/Ref.t t/modules/Util/Stash.t t/modules/Util/Sub.t t/modules/Util/Table.t t/modules/Util/Table/Cell.t t/modules/Util/Table/LineBreak.t t/modules/Util/Times.t t/modules/V0.t t/modules/Workflow.t t/modules/Workflow/BlockBase.t t/modules/Workflow/Build.t t/modules/Workflow/Runner.t t/modules/Workflow/Task.t t/modules/Workflow/Task/Action.t t/modules/Workflow/Task/Group.t t/regression/10-set_and_dne.t t/regression/132-bool.t t/regression/247_check_ref_bool.t t/regression/27-1-Test2-Bundle-More.t t/regression/27-2-Test2-Tools-Compare.t t/regression/27-3-Test2-Tools-ClassicCompare.t t/regression/285-wrap-nonexisting.t t/regression/289-compare-array-bounds.t t/regression/291-async-subtest-done-testing.t t/regression/43-bag-on-empty.t t/regression/642_persistent_end.t t/regression/662-tbt-no-plan.t t/regression/684-nested_todo_diag.t t/regression/694_note_diag_return_values.t t/regression/696-intercept_skip_all.t t/regression/721-nested-streamed-subtest.t t/regression/757-reset_in_subtest.t t/regression/812-todo.t t/regression/817-subtest-todo.t t/regression/862-intercept_tb_todo.t t/regression/Test2-Mock.t t/regression/Test2-Tools-Class.t t/regression/async_subtest_missing_parent.t t/regression/builder_does_not_init.t t/regression/errors_facet.t t/regression/fork_first.t t/regression/inherit_trace.t t/regression/no_name_in_subtest.t t/regression/skip_reason_object_ipc.t t/regression/todo_and_facets.t t/regression/utf8-mock.t t/zzz-check-breaks.t cpanfile100644001750001750 162514772042322 16225 0ustar00exodistexodist000000000000Test-Simple-1.302210# This file is generated by Dist::Zilla::Plugin::CPANFile v6.032 # Do not edit this file directly. To change prereqs, edit the `dist.ini` file. requires "B" => "0"; requires "Data::Dumper" => "0"; requires "Exporter" => "0"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "Scalar::Util" => "1.13"; requires "Storable" => "0"; requires "Term::Table" => "0.013"; requires "Time::HiRes" => "0"; requires "overload" => "0"; requires "perl" => "5.006002"; requires "utf8" => "0"; suggests "Module::Pluggable" => "2.7"; suggests "Term::ReadKey" => "0"; suggests "Term::Size::Any" => "0"; suggests "Unicode::GCString" => "0"; suggests "Unicode::LineBreak" => "0"; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "0"; }; on 'develop' => sub { requires "IPC::Open3" => "0"; requires "Term::Table" => "0.013"; requires "Test::Pod" => "1.41"; requires "Test::Spelling" => "0.12"; }; META.yml100644001750001750 304414772042322 15767 0ustar00exodistexodist000000000000Test-Simple-1.302210--- abstract: 'Basic utilities for writing tests.' author: - 'Chad Granum ' build_requires: {} configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.032, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-Simple requires: B: '0' Data::Dumper: '0' Exporter: '0' File::Spec: '0' File::Temp: '0' Scalar::Util: '1.13' Storable: '0' Term::Table: '0.013' Time::HiRes: '0' overload: '0' perl: '5.006002' utf8: '0' resources: bugtracker: https://github.com/Test-More/test-more/issues repository: https://github.com/Test-More/test-more/ version: '1.302210' x_breaks: Log::Dispatch::Config::TestLog: '<= 0.02' Net::BitTorrent: '<= 0.052' Test2::Harness: '<= 0.000013' Test2::Tools::EventDumper: '<= 0.000007' Test::Able: '<= 0.11' Test::Aggregate: '<= 0.373' Test::Alien: '<= 0.04' Test::Builder::Clutch: '<= 0.07' Test::Clustericious::Cluster: '<= 0.30' Test::Dist::VersionSync: '<= v1.1.4' Test::Exception: '<= 0.42' Test::Flatten: '<= 0.11' Test::Group: '<= 0.20' Test::Modern: '<= 0.012' Test::Moose: '<= 2.1209' Test::More::Prefix: '<= 0.005' Test::ParallelSubtest: '<= 0.05' Test::Pretty: '<= 0.32' Test::SharedFork: '<= 0.34' Test::UseAllModules: '>= 0.12, <= 0.14' Test::Wrapper: '<= v0.3.0' x_generated_by_perl: v5.40.1 x_serialization_backend: 'YAML::Tiny version 1.76' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' lib000755001750001750 014772042322 15123 5ustar00exodistexodist000000000000Test-Simple-1.302210ok.pm100644001750001750 171314772042322 16234 0ustar00exodistexodist000000000000Test-Simple-1.302210/libpackage ok; our $VERSION = '1.302210'; use strict; use Test::More (); sub import { shift; if (@_) { goto &Test::More::pass if $_[0] eq 'ok'; goto &Test::More::use_ok; } # No argument list - croak as if we are prototyped like use_ok() my (undef, $file, $line) = caller(); ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n"; } __END__ =encoding UTF-8 =head1 NAME ok - Alternative to Test::More::use_ok =head1 SYNOPSIS use ok 'Some::Module'; =head1 DESCRIPTION With this module, simply change all C in test scripts to C, and they will be executed at C time. Please see L for the full description. =head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L. This work is published from Taiwan. L =cut META.json100644001750001750 526114772042322 16142 0ustar00exodistexodist000000000000Test-Simple-1.302210{ "abstract" : "Basic utilities for writing tests.", "author" : [ "Chad Granum " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.032, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Test-Simple", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "IPC::Open3" : "0", "Term::Table" : "0.013", "Test::Pod" : "1.41", "Test::Spelling" : "0.12" } }, "runtime" : { "requires" : { "B" : "0", "Data::Dumper" : "0", "Exporter" : "0", "File::Spec" : "0", "File::Temp" : "0", "Scalar::Util" : "1.13", "Storable" : "0", "Term::Table" : "0.013", "Time::HiRes" : "0", "overload" : "0", "perl" : "5.006002", "utf8" : "0" }, "suggests" : { "Module::Pluggable" : "2.7", "Term::ReadKey" : "0", "Term::Size::Any" : "0", "Unicode::GCString" : "0", "Unicode::LineBreak" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/Test-More/test-more/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/Test-More/test-more/" } }, "version" : "1.302210", "x_breaks" : { "Log::Dispatch::Config::TestLog" : "<= 0.02", "Net::BitTorrent" : "<= 0.052", "Test2::Harness" : "<= 0.000013", "Test2::Tools::EventDumper" : "<= 0.000007", "Test::Able" : "<= 0.11", "Test::Aggregate" : "<= 0.373", "Test::Alien" : "<= 0.04", "Test::Builder::Clutch" : "<= 0.07", "Test::Clustericious::Cluster" : "<= 0.30", "Test::Dist::VersionSync" : "<= v1.1.4", "Test::Exception" : "<= 0.42", "Test::Flatten" : "<= 0.11", "Test::Group" : "<= 0.20", "Test::Modern" : "<= 0.012", "Test::Moose" : "<= 2.1209", "Test::More::Prefix" : "<= 0.005", "Test::ParallelSubtest" : "<= 0.05", "Test::Pretty" : "<= 0.32", "Test::SharedFork" : "<= 0.34", "Test::UseAllModules" : ">= 0.12, <= 0.14", "Test::Wrapper" : "<= v0.3.0" }, "x_generated_by_perl" : "v5.40.1", "x_serialization_backend" : "Cpanel::JSON::XS version 4.39", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } README.md100644001750001750 1542114772042322 16017 0ustar00exodistexodist000000000000Test-Simple-1.302210# NAME Test2 - Framework for writing test tools that all work together. # DESCRIPTION Test2 is a new testing framework produced by forking [Test::Builder](https://metacpan.org/pod/Test%3A%3ABuilder), completely refactoring it, adding many new features and capabilities. ## WHAT IS NEW? - Easier to test new testing tools. From the beginning Test2 was built with introspection capabilities. With Test::Builder it was difficult at best to capture test tool output for verification. Test2 Makes it easy with `Test2::API::intercept()`. - Better diagnostics capabilities. Test2 uses an [Test2::API::Context](https://metacpan.org/pod/Test2%3A%3AAPI%3A%3AContext) object to track filename, line number, and tool details. This object greatly simplifies tracking for where errors should be reported. - Event driven. Test2 based tools produce events which get passed through a processing system before being output by a formatter. This event system allows for rich plugin and extension support. - More complete API. Test::Builder only provided a handful of methods for generating lines of TAP. Test2 took inventory of everything people were doing with Test::Builder that required hacking it up. Test2 made public API functions for nearly all the desired functionality people didn't previously have. - Support for output other than TAP. Test::Builder assumed everything would end up as TAP. Test2 makes no such assumption. Test2 provides ways for you to specify alternative and custom formatters. - Subtest implementation is more sane. The Test::Builder implementation of subtests was certifiably insane. Test2 uses a stacked event hub system that greatly improves how subtests are implemented. - Support for threading/forking. Test2 support for forking and threading can be turned on using [Test2::IPC](https://metacpan.org/pod/Test2%3A%3AIPC). Once turned on threading and forking operate sanely and work as one would expect. # GETTING STARTED If you are interested in writing tests using new tools then you should look at [Test2::Suite](https://metacpan.org/pod/Test2%3A%3ASuite). [Test2::Suite](https://metacpan.org/pod/Test2%3A%3ASuite) is a separate cpan distribution that contains many tools implemented on Test2. If you are interested in writing new tools you should take a look at [Test2::API](https://metacpan.org/pod/Test2%3A%3AAPI) first. # NAMESPACE LAYOUT This describes the namespace layout for the Test2 ecosystem. Not all the namespaces listed here are part of the Test2 distribution, some are implemented in [Test2::Suite](https://metacpan.org/pod/Test2%3A%3ASuite). ## Test2::Tools:: This namespace is for sets of tools. Modules in this namespace should export tools like `ok()` and `is()`. Most things written for Test2 should go here. Modules in this namespace **MUST NOT** export subs from other tools. See the ["Test2::Bundle::"](#test2-bundle) namespace if you want to do that. ## Test2::Plugin:: This namespace is for plugins. Plugins are modules that change or enhance the behavior of Test2. An example of a plugin is a module that sets the encoding to utf8 globally. Another example is a module that causes a bail-out event after the first test failure. ## Test2::Bundle:: This namespace is for bundles of tools and plugins. Loading one of these may load multiple tools and plugins. Modules in this namespace should not implement tools directly. In general modules in this namespace should load tools and plugins, then re-export things into the consumers namespace. ## Test2::Require:: This namespace is for modules that cause a test to be skipped when conditions do not allow it to run. Examples would be modules that skip the test on older perls, or when non-essential modules have not been installed. ## Test2::Formatter:: Formatters live under this namespace. [Test2::Formatter::TAP](https://metacpan.org/pod/Test2%3A%3AFormatter%3A%3ATAP) is the only formatter currently. It is acceptable for third party distributions to create new formatters under this namespace. ## Test2::Event:: Events live under this namespace. It is considered acceptable for third party distributions to add new event types in this namespace. ## Test2::Hub:: Hub subclasses (and some hub utility objects) live under this namespace. It is perfectly reasonable for third party distributions to add new hub subclasses in this namespace. ## Test2::IPC:: The IPC subsystem lives in this namespace. There are not many good reasons to add anything to this namespace, with exception of IPC drivers. ### Test2::IPC::Driver:: IPC drivers live in this namespace. It is fine to create new IPC drivers and to put them in this namespace. ## Test2::Util:: This namespace is for general utilities used by testing tools. Please be considerate when adding new modules to this namespace. ## Test2::API:: This is for Test2 API and related packages. ## Test2:: The Test2:: namespace is intended for extensions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extensions that are used to build tools and plugins may go here. In short: If the module exports anything that should be run directly by a test script it should probably NOT go directly into `Test2::XXX`. # SEE ALSO [Test2::API](https://metacpan.org/pod/Test2%3A%3AAPI) - Primary API functions. [Test2::API::Context](https://metacpan.org/pod/Test2%3A%3AAPI%3A%3AContext) - Detailed documentation of the context object. [Test2::IPC](https://metacpan.org/pod/Test2%3A%3AIPC) - The IPC system used for threading/fork support. [Test2::Formatter](https://metacpan.org/pod/Test2%3A%3AFormatter) - Formatters such as TAP live here. [Test2::Event](https://metacpan.org/pod/Test2%3A%3AEvent) - Events live in this namespace. [Test2::Hub](https://metacpan.org/pod/Test2%3A%3AHub) - All events eventually funnel through a hub. Custom hubs are how `intercept()` and `run_subtest()` are implemented. # CONTACTING US Many Test2 developers and users lurk on [irc://irc.perl.org/#perl-qa](irc://irc.perl.org/#perl-qa) and [irc://irc.perl.org/#toolchain](irc://irc.perl.org/#toolchain). We also have a slack team that can be joined by anyone with an `@cpan.org` email address [https://perl-test2.slack.com/](https://perl-test2.slack.com/) If you do not have an `@cpan.org` email you can ask for a slack invite by emailing Chad Granum . # SOURCE The source code repository for Test2 can be found at [https://github.com/Test-More/test-more/](https://github.com/Test-More/test-more/). # MAINTAINERS - Chad Granum # AUTHORS - Chad Granum # COPYRIGHT Copyright Chad Granum . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See [https://dev.perl.org/licenses/](https://dev.perl.org/licenses/) perltidyrc100644001750001750 226014772042322 16621 0ustar00exodistexodist000000000000Test-Simple-1.302210--indent-columns=4 # size of indentation --nt # no tabs --entab-leading-whitespace=4 # 4 spaces to a tab when converting to tabs --continuation-indentation=4 # indentation of wrapped lines --maximum-line-length=0 # max line length before wrapping (turn it off) --nooutdent-long-quotes # do not outdent overly long quotes --paren-tightness=2 # no spacing for parentheses --square-bracket-tightness=2 # no spacing for square brackets --brace-tightness=2 # no spacing for hash curly braces --block-brace-tightness=0 # spacing for coderef curly braces --comma-arrow-breakpoints=1 # break long key/value pair lists --break-at-old-comma-breakpoints # this attempts to retain list break points --no-blanks-before-comments # do not insert blank lines before comments --indent-spaced-block-comments # no blanks before comments --nocuddled-else # Do not cuddle else --nospace-for-semicolon # no space before semicolons in loops --nospace-terminal-semicolon # no space before termonal semicolons --notrim-qw # Do not mess with qw{} whitespace Makefile.PL100644001750001750 465714772042322 16503 0ustar00exodistexodist000000000000Test-Simple-1.302210# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.032. use strict; use warnings; use 5.006002; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Basic utilities for writing tests.", "AUTHOR" => "Chad Granum ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "Test-Simple", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.006002", "NAME" => "Test::Simple", "PREREQ_PM" => { "B" => 0, "Data::Dumper" => 0, "Exporter" => 0, "File::Spec" => 0, "File::Temp" => 0, "Scalar::Util" => "1.13", "Storable" => 0, "Term::Table" => "0.013", "Time::HiRes" => 0, "overload" => 0, "utf8" => 0 }, "VERSION" => "1.302210", "test" => { "TESTS" => "t/*.t t/Legacy/*.t t/Legacy/Bugs/*.t t/Legacy/Builder/*.t t/Legacy/Regression/*.t t/Legacy/Simple/*.t t/Legacy/Test2/*.t t/Legacy/Tester/*.t t/Legacy/subtest/*.t t/Legacy_And_Test2/*.t t/Test2/acceptance/*.t t/Test2/behavior/*.t t/Test2/legacy/*.t t/Test2/modules/*.t t/Test2/modules/API/*.t t/Test2/modules/API/InterceptResult/*.t t/Test2/modules/Event/*.t t/Test2/modules/Event/TAP/*.t t/Test2/modules/EventFacet/*.t t/Test2/modules/Formatter/*.t t/Test2/modules/Hub/*.t t/Test2/modules/Hub/Interceptor/*.t t/Test2/modules/IPC/*.t t/Test2/modules/IPC/Driver/*.t t/Test2/modules/Tools/*.t t/Test2/modules/Util/*.t t/Test2/regression/*.t t/acceptance/*.t t/behavior/*.t t/modules/*.t t/modules/AsyncSubtest/*.t t/modules/AsyncSubtest/Event/*.t t/modules/Bundle/*.t t/modules/Compare/*.t t/modules/Plugin/*.t t/modules/Require/*.t t/modules/Tools/*.t t/modules/Tools/Test-Refcount/*.t t/modules/Util/*.t t/modules/Util/Table/*.t t/modules/Workflow/*.t t/modules/Workflow/Task/*.t t/regression/*.t" } ); my %FallbackPrereqs = ( "B" => 0, "Data::Dumper" => 0, "Exporter" => 0, "File::Spec" => 0, "File::Temp" => 0, "Scalar::Util" => "1.13", "Storable" => 0, "Term::Table" => "0.013", "Time::HiRes" => 0, "overload" => 0, "utf8" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; $WriteMakefileArgs{INSTALLDIRS} = 'perl' if "$]" >= 5.006002 && "$]" <= 5.011000; WriteMakefile(%WriteMakefileArgs); appveyor.yml100644001750001750 126514772042322 17111 0ustar00exodistexodist000000000000Test-Simple-1.302210skip_tags: true cache: - C:\strawberry install: - if not exist "C:\strawberry" cinst strawberryperl -y - set PATH=C:\strawberry\perl\bin;C:\strawberry\perl\site\bin;C:\strawberry\c\bin;%PATH% - cd C:\projects\%APPVEYOR_PROJECT_NAME% - cpanm -n Dist::Zilla Pod::Markdown - dzil authordeps --missing | cpanm -n - dzil listdeps --author --missing | cpanm build_script: - perl -e 2 test_script: - dzil test notifications: - provider: Slack auth_token: secure: 1XmVVszAQyTtMdNkyWup8p7AC9iqXkMl6QMchq3Xu7L7rCzYgjjlS/mas+bfp3ouyjPKnoh01twl4eB0Xs/1Ig== channel: '#general' on_build_success: false on_build_failure: true on_build_status_changed: true Test2.pm100644001750001750 1436614772042322 16654 0ustar00exodistexodist000000000000Test-Simple-1.302210/libpackage Test2; use strict; use warnings; our $VERSION = '1.302210'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2 - Framework for writing test tools that all work together. =head1 DESCRIPTION Test2 is a new testing framework produced by forking L, completely refactoring it, adding many new features and capabilities. =head2 WHAT IS NEW? =over 4 =item Easier to test new testing tools. From the beginning Test2 was built with introspection capabilities. With Test::Builder it was difficult at best to capture test tool output for verification. Test2 Makes it easy with C. =item Better diagnostics capabilities. Test2 uses an L object to track filename, line number, and tool details. This object greatly simplifies tracking for where errors should be reported. =item Event driven. Test2 based tools produce events which get passed through a processing system before being output by a formatter. This event system allows for rich plugin and extension support. =item More complete API. Test::Builder only provided a handful of methods for generating lines of TAP. Test2 took inventory of everything people were doing with Test::Builder that required hacking it up. Test2 made public API functions for nearly all the desired functionality people didn't previously have. =item Support for output other than TAP. Test::Builder assumed everything would end up as TAP. Test2 makes no such assumption. Test2 provides ways for you to specify alternative and custom formatters. =item Subtest implementation is more sane. The Test::Builder implementation of subtests was certifiably insane. Test2 uses a stacked event hub system that greatly improves how subtests are implemented. =item Support for threading/forking. Test2 support for forking and threading can be turned on using L. Once turned on threading and forking operate sanely and work as one would expect. =back =head1 GETTING STARTED If you are interested in writing tests using new tools then you should look at L. L is a separate cpan distribution that contains many tools implemented on Test2. If you are interested in writing new tools you should take a look at L first. =head1 NAMESPACE LAYOUT This describes the namespace layout for the Test2 ecosystem. Not all the namespaces listed here are part of the Test2 distribution, some are implemented in L. =head2 Test2::Tools:: This namespace is for sets of tools. Modules in this namespace should export tools like C and C. Most things written for Test2 should go here. Modules in this namespace B export subs from other tools. See the L namespace if you want to do that. =head2 Test2::Plugin:: This namespace is for plugins. Plugins are modules that change or enhance the behavior of Test2. An example of a plugin is a module that sets the encoding to utf8 globally. Another example is a module that causes a bail-out event after the first test failure. =head2 Test2::Bundle:: This namespace is for bundles of tools and plugins. Loading one of these may load multiple tools and plugins. Modules in this namespace should not implement tools directly. In general modules in this namespace should load tools and plugins, then re-export things into the consumers namespace. =head2 Test2::Require:: This namespace is for modules that cause a test to be skipped when conditions do not allow it to run. Examples would be modules that skip the test on older perls, or when non-essential modules have not been installed. =head2 Test2::Formatter:: Formatters live under this namespace. L is the only formatter currently. It is acceptable for third party distributions to create new formatters under this namespace. =head2 Test2::Event:: Events live under this namespace. It is considered acceptable for third party distributions to add new event types in this namespace. =head2 Test2::Hub:: Hub subclasses (and some hub utility objects) live under this namespace. It is perfectly reasonable for third party distributions to add new hub subclasses in this namespace. =head2 Test2::IPC:: The IPC subsystem lives in this namespace. There are not many good reasons to add anything to this namespace, with exception of IPC drivers. =head3 Test2::IPC::Driver:: IPC drivers live in this namespace. It is fine to create new IPC drivers and to put them in this namespace. =head2 Test2::Util:: This namespace is for general utilities used by testing tools. Please be considerate when adding new modules to this namespace. =head2 Test2::API:: This is for Test2 API and related packages. =head2 Test2:: The Test2:: namespace is intended for extensions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extensions that are used to build tools and plugins may go here. In short: If the module exports anything that should be run directly by a test script it should probably NOT go directly into C. =head1 SEE ALSO L - Primary API functions. L - Detailed documentation of the context object. L - The IPC system used for threading/fork support. L - Formatters such as TAP live here. L - Events live in this namespace. L - All events eventually funnel through a hub. Custom hubs are how C and C are implemented. =head1 CONTACTING US Many Test2 developers and users lurk on L and L. We also have a slack team that can be joined by anyone with an C<@cpan.org> email address L If you do not have an C<@cpan.org> email you can ask for a slack invite by emailing Chad Granum Eexodist@cpan.orgE. =head1 SOURCE The source code repository for Test2 can be found at 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 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 t000755001750001750 014772042322 14620 5ustar00exodistexodist000000000000Test-Simple-1.302210HashBase.t100644001750001750 1372614772042322 16654 0ustar00exodistexodist000000000000Test-Simple-1.302210/tuse strict; use warnings; use Test::More; sub warnings(&) { my $code = shift; my @warnings; local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return \@warnings; } sub exception(&) { my $code = shift; local ($@, $!, $SIG{__DIE__}); my $ok = eval { $code->(); 1 }; my $error = $@ || 'SQUASHED ERROR'; return $ok ? undef : $error; } BEGIN { $INC{'Object/HashBase/Test/HBase.pm'} = __FILE__; package main::HBase; use Test2::Util::HashBase qw/foo bar baz/; main::is(FOO, 'foo', "FOO CONSTANT"); main::is(BAR, 'bar', "BAR CONSTANT"); main::is(BAZ, 'baz', "BAZ CONSTANT"); } BEGIN { package main::HBaseSub; use base 'main::HBase'; use Test2::Util::HashBase qw/apple pear/; main::is(FOO, 'foo', "FOO CONSTANT"); main::is(BAR, 'bar', "BAR CONSTANT"); main::is(BAZ, 'baz', "BAZ CONSTANT"); main::is(APPLE, 'apple', "APPLE CONSTANT"); main::is(PEAR, 'pear', "PEAR CONSTANT"); } my $one = main::HBase->new(foo => 'a', bar => 'b', baz => 'c'); is($one->foo, 'a', "Accessor"); is($one->bar, 'b', "Accessor"); is($one->baz, 'c', "Accessor"); $one->set_foo('x'); is($one->foo, 'x', "Accessor set"); $one->set_foo(undef); is_deeply( $one, { foo => undef, bar => 'b', baz => 'c', }, 'hash' ); BEGIN { package main::Const::Test; use Test2::Util::HashBase qw/foo/; sub do_it { if (FOO()) { return 'const'; } return 'not const' } } my $pkg = 'main::Const::Test'; is($pkg->do_it, 'const', "worked as expected"); { local $SIG{__WARN__} = sub { }; *main::Const::Test::FOO = sub { 0 }; } ok(!$pkg->FOO, "overrode const sub"); { local $TODO = "known to fail on $]" if "$]" <= 5.006002; is($pkg->do_it, 'const', "worked as expected, const was constant"); } BEGIN { $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__; package main::HBase::Wrapped; use Test2::Util::HashBase qw/foo bar dup/; my $foo = __PACKAGE__->can('foo'); no warnings 'redefine'; *foo = sub { my $self = shift; $self->set_bar(1); $self->$foo(@_); }; } BEGIN { $INC{'Object/HashBase/Test/HBase/Wrapped/Inherit.pm'} = __FILE__; package main::HBase::Wrapped::Inherit; use base 'main::HBase::Wrapped'; use Test2::Util::HashBase qw/baz dup/; } my $o = main::HBase::Wrapped::Inherit->new(foo => 1); my $foo = $o->foo; is($o->bar, 1, 'parent attribute sub not overridden'); { package Foo; sub new; use Test2::Util::HashBase qw/foo bar baz/; sub new { 'foo' }; } is(Foo->new, 'foo', "Did not override existing 'new' method"); BEGIN { $INC{'Object/HashBase/Test/HBase2.pm'} = __FILE__; package main::HBase2; use Test2::Util::HashBase qw/foo -bar ^baz ban +boo/; main::is(FOO, 'foo', "FOO CONSTANT"); main::is(BAR, 'bar', "BAR CONSTANT"); main::is(BAZ, 'baz', "BAZ CONSTANT"); main::is(BAT, 'bat', "BAT CONSTANT"); main::is(BAN, 'ban', "BAN CONSTANT"); main::is(BOO, 'boo', "BOO CONSTANT"); } my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz', bat => 'bat', ban => 'ban'); is($ro->foo, 'foo', "got foo"); is($ro->bar, 'bar', "got bar"); is($ro->baz, 'baz', "got baz"); is($ro->bat, 'bat', "got bat"); ok(!$ro->can('set_bat'), "No setter for bat"); ok(!$ro->can('ban'), "No reader for ban"); ok(!$ro->can('boo'), "No reader for boo"); ok(!$ro->can('set_boo'), "No setter for boo"); is($ro->{ban}, 'ban', "ban attribute is set"); $ro->set_ban('xxx'); is($ro->{ban}, 'xxx', "ban attribute can be set"); is($ro->set_foo('xxx'), 'xxx', "Can set foo"); is($ro->foo, 'xxx', "got foo"); like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar"); my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') }; like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning"); is_deeply( [Test2::Util::HashBase::attr_list('main::HBase::Wrapped::Inherit')], [qw/foo bar dup baz/], "Got a list of attributes in order starting from base class, duplicates removed", ); my $x = main::HBase::Wrapped::Inherit->new(foo => 1, baz => 2); is($x->foo, 1, "set foo via pairs"); is($x->baz, 2, "set baz via pairs"); # Now with hashref my $y = main::HBase::Wrapped::Inherit->new({foo => 1, baz => 2}); is($y->foo, 1, "set foo via hashref"); is($y->baz, 2, "set baz via hashref"); # Now with hashref my $z = main::HBase::Wrapped::Inherit->new([ 1, # foo 2, # bar 3, # dup 4, # baz ]); is($z->foo, 1, "set foo via arrayref"); is($z->baz, 4, "set baz via arrayref"); like( exception { main::HBase::Wrapped::Inherit->new([1 .. 10]) }, qr/Too many arguments for main::HBase::Wrapped::Inherit constructor/, "Too many args in array form" ); my $CAN_COUNT = 0; my $CAN_COUNT2 = 0; my $INIT_COUNT = 0; BEGIN { $INC{'Object/HashBase/Test/HBase3.pm'} = __FILE__; package main::HBase3; use Test2::Util::HashBase qw/foo/; sub can { my $self = shift; $CAN_COUNT++; $self->SUPER::can(@_); } $INC{'Object/HashBase/Test/HBase4.pm'} = __FILE__; package main::HBase4; use Test2::Util::HashBase qw/foo/; sub can { my $self = shift; $CAN_COUNT2++; $self->SUPER::can(@_); } sub init { $INIT_COUNT++ } } is($CAN_COUNT, 0, "->can has not been called yet"); my $it = main::HBase3->new; is($CAN_COUNT, 1, "->can has been called once to check for init"); $it = main::HBase3->new; is($CAN_COUNT, 1, "->can was not called again, we cached it"); is($CAN_COUNT2, 0, "->can has not been called yet"); is($INIT_COUNT, 0, "->init has not been called yet"); $it = main::HBase4->new; is($CAN_COUNT2, 1, "->can has been called once to check for init"); is($INIT_COUNT, 1, "->init has been called once"); $it = main::HBase4->new; is($CAN_COUNT2, 1, "->can was not called again, we cached it"); is($INIT_COUNT, 2, "->init has been called again"); done_testing; 1; 00-report.t100644001750001750 343714772042322 16704 0ustar00exodistexodist000000000000Test-Simple-1.302210/tuse strict; use warnings; # Nothing in the tables in this file should result in a table wider than 80 # characters, so this is an optimization. BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } use File::Spec; use Test2::Tools::Basic; use Test2::Util::Table qw/table/; use Test2::Util qw/CAN_FORK CAN_REALLY_FORK CAN_THREAD/; my $exit = 0; END{ $? = $exit } diag "\nDIAGNOSTICS INFO IN CASE OF FAILURE:\n"; diag(join "\n", table(rows => [[ 'perl', $] ]])); diag( join "\n", table( header => [qw/CAPABILITY SUPPORTED/], rows => [ ['CAN_FORK', CAN_FORK ? 'Yes' : 'No'], ['CAN_REALLY_FORK', CAN_REALLY_FORK ? 'Yes' : 'No'], ['CAN_THREAD', CAN_THREAD ? 'Yes' : 'No'], ], ) ); { my @depends = qw{ B Carp Exporter File::Spec File::Temp PerlIO Scalar::Util Storable Term::Table Test2 Time::HiRes overload threads utf8 }; my @rows; for my $mod (sort @depends) { my $installed = eval "require $mod; $mod->VERSION"; push @rows => [ $mod, $installed || "N/A" ]; } my @table = table( header => [ 'DEPENDENCY', 'VERSION' ], rows => \@rows, ); diag(join "\n", @table); } { my @options = qw{ Module::Pluggable Sub::Name Term::ReadKey Term::Size::Any Unicode::GCString Unicode::LineBreak }; my @rows; for my $mod (sort @options) { my $installed = eval "require $mod; $mod->VERSION"; push @rows => [ $mod, $installed || "N/A" ]; } my @table = table( header => [ 'OPTIONAL', 'VERSION' ], rows => \@rows, ); diag(join "\n", @table); } pass; done_testing; 00compile.t100644001750001750 213614772042322 16737 0ustar00exodistexodist000000000000Test-Simple-1.302210/t#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::More; my $Has_Test_Pod; BEGIN { $Has_Test_Pod = eval 'use Test::Pod 0.95; 1'; } chdir ".."; my $manifest = "MANIFEST"; open(my $manifest_fh, "<", $manifest) or plan(skip_all => "Can't open $manifest: $!"); my @modules = map { m{^lib/(\S+)}; $1 } grep { m{^lib/Test/\S*\.pm} } grep { !m{/t/} } <$manifest_fh>; chomp @modules; close $manifest_fh; chdir 'lib'; plan tests => scalar @modules * 2; foreach my $file (@modules) { # Make sure we look at the local files and do not reload them if # they're already loaded. This avoids recompilation warnings. local @INC = @INC; unshift @INC, "."; my @warnings; ok eval { local $SIG{__WARN__} = sub { push @warnings => @_ }; require($file); 1 } or diag "require $file failed.", "\n", @warnings, "\n", $@; SKIP: { skip "Test::Pod not installed", 1 unless $Has_Test_Pod; pod_file_ok($file); } } modules000755001750001750 014772042322 16270 5ustar00exodistexodist000000000000Test-Simple-1.302210/tV0.t100644001750001750 500714772042322 17104 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse 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; lib000755001750001750 014772042322 15366 5ustar00exodistexodist000000000000Test-Simple-1.302210/tDummy.pm100644001750001750 6714772042322 17122 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libpackage Dummy; use strict; our $VERSION = '0.01'; 1; Test2000755001750001750 014772042322 16124 5ustar00exodistexodist000000000000Test-Simple-1.302210/libV0.pm100644001750001750 2722214772042322 17134 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::V0; use strict; use warnings; use Test2::Util::Importer; our $VERSION = '1.302210'; 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; You can also disable this behavior: use Test2::V0 -no_srand => 1; B When srand is on (default) it can cause problems with things like L which will end up attempting the same "random" filenames for every test process started on a given day (or sharing the same seed). =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 ENVIRONMENT VARIABLES See L for a list of meaningul environment variables. =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 = bool($bool) =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 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 load_manual.t100644001750001750 13114772042322 17374 0ustar00exodistexodist000000000000Test-Simple-1.302210/tuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::Manual'; done_testing; Legacy000755001750001750 014772042322 16024 5ustar00exodistexodist000000000000Test-Simple-1.302210/tfork.t100644001750001750 71014772042322 17270 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w use strict; use warnings; use Test2::Util qw/CAN_FORK/; BEGIN { unless(CAN_FORK) { require Test::More; Test::More->import(skip_all => "fork is not supported"); } } BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; plan tests => 1; if( fork ) { # parent pass("Only the parent should process the ending, not the child"); } else { exit; # child } More.t100644001750001750 1345314772042322 17301 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = qw(../lib ../lib/Test/Simple/t/lib); } } use lib 't/lib'; use Test::More tests => 57; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; my $Errno = 42; $@ = $Err; $! = $Errno; use_ok('Dummy'); is( $Dummy::VERSION, '0.01', 'use_ok() loads a module' ); require_ok('Test::More'); ok( 2 eq 2, 'two is two is two is two' ); is( "foo", "foo", 'foo is foo' ); isnt( "foo", "bar", 'foo isnt bar'); { use warnings; my $warning; local $SIG{__WARN__}= sub { $warning = $_[0] }; isn::t("foo", "bar", 'foo isn\'t bar'); is($warning, "Use of apostrophe as package separator was deprecated in Perl 5.37.9,\n" . "and will be removed in Perl 5.42.0. You should change code that uses\n" . "Test::More::isn't() to use Test::More::isnt() as a replacement" . " at ${ \__FILE__ } line 31\n", "Got expected warning from isn::t() under use warnings"); } { no warnings "deprecated"; my $warning; local $SIG{__WARN__}= sub { $warning = $_[0] }; isn::t("foo", "bar", 'foo isn\'t bar'); is($warning, undef, "No warnings from isn::t() under no warnings deprecated"); } #'# like("fooble", '/^foo/', 'foo is like fooble'); like("FooBle", '/foo/i', 'foo is like FooBle'); like("/usr/local/pr0n/", '/^\/usr\/local/', 'regexes with slashes in like' ); unlike("fbar", '/^bar/', 'unlike bar'); unlike("FooBle", '/foo/', 'foo is unlike FooBle'); unlike("/var/local/pr0n/", '/^\/usr\/local/','regexes with slashes in unlike' ); my @foo = qw(foo bar baz); unlike(@foo, '/foo/'); can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok pass fail eq_array eq_hash eq_set)); can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip can_ok pass fail eq_array eq_hash eq_set)); isa_ok(bless([], "Foo"), "Foo"); isa_ok([], 'ARRAY'); isa_ok(\42, 'SCALAR'); { local %Bar::; local @Foo::ISA = 'Bar'; isa_ok( "Foo", "Bar" ); } # can_ok() & isa_ok should call can() & isa() on the given object, not # just class, in case of custom can() { local *Foo::can; local *Foo::isa; *Foo::can = sub { $_[0]->[0] }; *Foo::isa = sub { $_[0]->[0] }; my $foo = bless([0], 'Foo'); ok( ! $foo->can('bar') ); ok( ! $foo->isa('bar') ); $foo->[0] = 1; can_ok( $foo, 'blah'); isa_ok( $foo, 'blah'); } pass('pass() passed'); ok( eq_array([qw(this that whatever)], [qw(this that whatever)]), 'eq_array with simple arrays' ); is @Test::More::Data_Stack, 0, '@Data_Stack not holding onto things'; ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}), 'eq_hash with simple hashes' ); is @Test::More::Data_Stack, 0; ok( eq_set([qw(this that whatever)], [qw(that whatever this)]), 'eq_set with simple sets' ); is @Test::More::Data_Stack, 0; my @complex_array1 = ( [qw(this that whatever)], {foo => 23, bar => 42}, "moo", "yarrow", [qw(498 10 29)], ); my @complex_array2 = ( [qw(this that whatever)], {foo => 23, bar => 42}, "moo", "yarrow", [qw(498 10 29)], ); is_deeply( \@complex_array1, \@complex_array2, 'is_deeply with arrays' ); ok( eq_array(\@complex_array1, \@complex_array2), 'eq_array with complicated arrays' ); ok( eq_set(\@complex_array1, \@complex_array2), 'eq_set with complicated arrays' ); my @array1 = (qw(this that whatever), {foo => 23, bar => 42} ); my @array2 = (qw(this that whatever), {foo => 24, bar => 42} ); ok( !eq_array(\@array1, \@array2), 'eq_array with slightly different complicated arrays' ); is @Test::More::Data_Stack, 0; ok( !eq_set(\@array1, \@array2), 'eq_set with slightly different complicated arrays' ); is @Test::More::Data_Stack, 0; my %hash1 = ( foo => 23, bar => [qw(this that whatever)], har => { foo => 24, bar => 42 }, ); my %hash2 = ( foo => 23, bar => [qw(this that whatever)], har => { foo => 24, bar => 42 }, ); is_deeply( \%hash1, \%hash2, 'is_deeply with complicated hashes' ); ok( eq_hash(\%hash1, \%hash2), 'eq_hash with complicated hashes'); %hash1 = ( foo => 23, bar => [qw(this that whatever)], har => { foo => 24, bar => 42 }, ); %hash2 = ( foo => 23, bar => [qw(this tha whatever)], har => { foo => 24, bar => 42 }, ); ok( !eq_hash(\%hash1, \%hash2), 'eq_hash with slightly different complicated hashes' ); is @Test::More::Data_Stack, 0; is( Test::Builder->new, Test::More->builder, 'builder()' ); cmp_ok(42, '==', 42, 'cmp_ok =='); cmp_ok('foo', 'eq', 'foo', ' eq'); cmp_ok(42.5, '<', 42.6, ' <'); cmp_ok(0, '||', 1, ' ||'); # Piers pointed out sometimes people override isa(). { package Wibble; sub isa { my($self, $class) = @_; return 1 if $class eq 'Wibblemeister'; } sub new { bless {} } } isa_ok( Wibble->new, 'Wibblemeister' ); my $sub = sub {}; is_deeply( $sub, $sub, 'the same function ref' ); use Symbol; my $glob = gensym; is_deeply( $glob, $glob, 'the same glob' ); is_deeply( { foo => $sub, bar => [1, $glob] }, { foo => $sub, bar => [1, $glob] } ); # rt.cpan.org 53469 is_deeply with regexes is_deeply( qr/a/, qr/a/, "same regex" ); # These two tests must remain at the end. is( $@, $Err, '$@ untouched' ); cmp_ok( $!, '==', $Errno, '$! untouched' ); utf8.t100644001750001750 276314772042322 17247 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; use warnings; my $have_perlio; BEGIN { # All together so Test::More sees the open discipline $have_perlio = eval q[ require PerlIO; PerlIO->VERSION(1.02); # required for PerlIO::get_layers binmode *STDOUT, ":encoding(utf8)"; binmode *STDERR, ":encoding(utf8)"; require Test::More; 1; ]; } use Test::More; unless (Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter')) { plan skip_all => 'Test cannot be run using this formatter'; } if( !$have_perlio ) { plan skip_all => "Don't have PerlIO 1.02"; } else { plan tests => 5; } SKIP: { skip( "Need PerlIO for this feature", 3 ) unless $have_perlio; my %handles = ( output => \*STDOUT, failure_output => \*STDERR, todo_output => \*STDOUT ); for my $method (keys %handles) { my $src = $handles{$method}; my $dest = Test::More->builder->$method; is_deeply { map { $_ => 1 } PerlIO::get_layers($dest) }, { map { $_ => 1 } PerlIO::get_layers($src) }, "layers copied to $method"; } } # Test utf8 is ok. { my $uni = "\x{11e}"; my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; }; is( $uni, $uni, "Testing $uni" ); is_deeply( \@warnings, [] ); } todo.t100644001750001750 647614772042322 17333 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; use strict; use warnings; plan tests => 36; my $Why = 'Just testing the todo interface.'; my $is_todo; TODO: { local $TODO = $Why; fail("Expected failure"); fail("Another expected failure"); $is_todo = Test::More->builder->todo; } pass("This is not todo"); ok( $is_todo, 'TB->todo' ); TODO: { local $TODO = $Why; fail("Yet another failure"); } pass("This is still not todo"); TODO: { local $TODO = "testing that error messages don't leak out of todo"; ok( 'this' eq 'that', 'ok' ); like( 'this', qr/that/, 'like' ); is( 'this', 'that', 'is' ); isnt( 'this', 'this', 'isnt' ); can_ok('Fooble', 'yarble'); isa_ok('Fooble', 'yarble'); use_ok('Fooble'); require_ok('Fooble'); } TODO: { todo_skip "Just testing todo_skip", 2; fail("Just testing todo"); die "todo_skip should prevent this"; pass("Again"); } { my $warning; local $SIG{__WARN__} = sub { $warning = join "", @_ }; TODO: { # perl gets the line number a little wrong on the first # statement inside a block. 1 == 1; #line 74 todo_skip "Just testing todo_skip"; fail("So very failed"); } is( $warning, "todo_skip() needs to know \$how_many tests are in the ". "block at $0 line 74\n", 'todo_skip without $how_many warning' ); } my $builder = Test::More->builder; my $exported_to = $builder->exported_to; TODO: { $builder->exported_to("Wibble"); local $TODO = "testing \$TODO with an incorrect exported_to()"; fail("Just testing todo"); } $builder->exported_to($exported_to); $builder->todo_start('Expected failures'); fail('Testing todo_start()'); ok 0, 'Testing todo_start() with more than one failure'; $is_todo = $builder->todo; $builder->todo_end; is $is_todo, 'Expected failures', 'todo_start should have the correct TODO message'; ok 1, 'todo_end() should not leak TODO behavior'; my @nested_todo; my ( $level1, $level2 ) = ( 'failure level 1', 'failure_level 2' ); TODO: { local $TODO = 'Nesting TODO'; fail('fail 1'); $builder->todo_start($level1); fail('fail 2'); push @nested_todo => $builder->todo; $builder->todo_start($level2); fail('fail 3'); push @nested_todo => $builder->todo; $builder->todo_end; fail('fail 4'); push @nested_todo => $builder->todo; $builder->todo_end; $is_todo = $builder->todo; fail('fail 4'); } is_deeply \@nested_todo, [ $level1, $level2, $level1 ], 'Nested TODO message should be correct'; is $is_todo, 'Nesting TODO', '... and original TODO message should be correct'; { $builder->todo_start; fail("testing todo_start() with no message"); my $reason = $builder->todo; my $in_todo = $builder->in_todo; $builder->todo_end; is $reason, '', " todo() reports no reason"; ok $in_todo, " but we're in_todo()"; } eval { $builder->todo_end; }; is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 3; { my($reason, $in_todo); TODO: { local $TODO = ''; $reason = $builder->todo; $in_todo = $builder->in_todo; } is $reason, ''; ok !$in_todo, '$TODO = "" is not considered TODO'; } note.t100644001750001750 64014772042322 17276 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::Builder::NoOutput; use Test::More tests => 2; { my $tb = Test::Builder::NoOutput->create; $tb->note("foo"); $tb->reset_outputs; is $tb->read('out'), "# foo\n"; is $tb->read('err'), ''; } auto.t100644001750001750 112614772042322 17321 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use warnings; use lib 't/lib'; use Test::Tester tests => 6; use SmallTest; use MyTest; { my ($prem, @results) = run_tests( sub { MyTest::ok(1, "run pass")} ); is_eq($results[0]->{name}, "run pass"); is_num($results[0]->{ok}, 1); } { my ($prem, @results) = run_tests( sub { MyTest::ok(0, "run fail")} ); is_eq($results[0]->{name}, "run fail"); is_num($results[0]->{ok}, 0); } is_eq(ref(SmallTest::getTest()), "Test::Tester::Delegate"); is_eq( SmallTest::getTest()->can('ok'), Test::Builder->can('ok'), "Delegate->can() returns the sub from the inner object", ); plan.t100644001750001750 73214772042322 17265 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; plan tests => 4; eval { plan tests => 4 }; is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ - 1), 'disallow double plan' ); eval { plan 'no_plan' }; is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ -1), 'disallow changing plan' ); pass('Just testing plan()'); pass('Testing it some more'); exit.t100644001750001750 625214772042322 17327 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # HARNESS-NO-STREAM # Can't use Test.pm, that's a 5.005 thing. package My::Test; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } require Test::Builder; my $TB = Test::Builder->create(); $TB->level(0); package main; use Cwd; use File::Spec; my $Orig_Dir = cwd; my $Perl = File::Spec->rel2abs($^X); if( $^O eq 'VMS' ) { # VMS can't use its own $^X in a system call until almost 5.8 $Perl = "MCR $^X" if $] < 5.007003; # Quiet noisy 'SYS$ABORT' $Perl .= q{ -"I../lib"} if $ENV{PERL_CORE}; $Perl .= q{ -"Mvmsish=hushed"}; } else { $Perl = qq("$Perl"); # protect from shell if spaces } eval { require POSIX; &POSIX::WEXITSTATUS(0) }; if( $@ ) { *exitstatus = sub { $_[0] >> 8 }; } else { *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) } } # Some OS' will alter the exit code to their own native sense... # sometimes. Rather than deal with the exception we'll just # build up the mapping. print "# Building up a map of exit codes. May take a while.\n"; my %Exit_Map; open my $fh, ">", "exit_map_test" or die $!; print $fh <<'DONE'; if ($^O eq 'VMS') { require vmsish; import vmsish qw(hushed); } my $exit = shift; print "exit $exit\n"; END { $? = $exit }; DONE close $fh; END { 1 while unlink "exit_map_test" } for my $exit (0..255) { # This correctly emulates Test::Builder's behavior. my $out = qx[$Perl exit_map_test $exit]; $TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" ); $Exit_Map{$exit} = exitstatus($?); } print "# Done.\n"; my %Tests = ( # File Exit Code 'success.plx' => 0, 'one_fail.plx' => 1, 'two_fail.plx' => 2, 'five_fail.plx' => 5, 'extras.plx' => 2, 'too_few.plx' => 255, 'too_few_fail.plx' => 2, 'death.plx' => 255, 'last_minute_death.plx' => 255, 'pre_plan_death.plx' => 'not zero', 'death_in_eval.plx' => 0, 'require.plx' => 0, 'death_with_handler.plx' => 255, 'exit.plx' => 1, 'one_fail_without_plan.plx' => 1, 'missing_done_testing.plx' => 254, ); chdir 't'; my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); while( my($test_name, $exit_code) = each %Tests ) { my $file = File::Spec->catfile($lib, $test_name); my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file}); my $actual_exit = exitstatus($wait_stat); if( $exit_code eq 'not zero' ) { $TB->isnt_num( $actual_exit, $Exit_Map{0}, "$test_name exited with $actual_exit ". "(expected non-zero)"); } else { $TB->is_num( $actual_exit, $Exit_Map{$exit_code}, "$test_name exited with $actual_exit ". "(expected $Exit_Map{$exit_code})"); } } $TB->done_testing( scalar keys(%Tests) + 256 ); # So any END block file cleanup works. chdir $Orig_Dir; fail.t100644001750001750 233614772042322 17270 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w # Simple test of what failure output looks like BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; # Normalize the output whether we're running under Test::Harness or not. local $ENV{HARNESS_ACTIVE} = 0; use Test::Builder; use Test::Builder::NoOutput; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; my $Test = Test::Builder->new; # Set up a builder to record some failing tests. { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 5 ); #line 28 $tb->$ok( 1, 'passing' ); $tb->$ok( 2, 'passing still' ); $tb->$ok( 3, 'still passing' ); $tb->$ok( 0, 'oh no!' ); $tb->$ok( 0, 'damnit' ); $tb->_ending; $Test->is_eq($tb->read('out'), <is_eq($tb->read('err'), <$done_testing(2); } died.t100644001750001750 157114772042322 17262 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 3); package main; require Test::Simple; chdir 't'; push @INC, '../t/lib/'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; Test::Simple->import(tests => 1); exit 250; END { $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 250, "exit code"); $? = grep { !$_ } $TB->summary; } diag.t100644001750001750 262014772042322 17255 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w use strict; use Test2::Util qw/CAN_THREAD/; # Turn on threads here, if available, since this test tends to find # lots of threading bugs. BEGIN { if (CAN_THREAD) { require threads; threads->import; } } BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder::NoOutput; use Test::More tests => 7; my $test = Test::Builder::NoOutput->create; # Test diag() goes to todo_output() in a todo test. { $test->todo_start(); $test->diag("a single line"); is( $test->read('todo'), <<'DIAG', 'diag() with todo_output set' ); # a single line DIAG my $ret = $test->diag("multiple\n", "lines"); is( $test->read('todo'), <<'DIAG', ' multi line' ); # multiple # lines DIAG ok( !$ret, 'diag returns false' ); $test->todo_end(); } # Test diagnostic formatting { $test->diag("# foo"); is( $test->read('err'), "# # foo\n", "diag() adds # even if there's one already" ); $test->diag("foo\n\nbar"); is( $test->read('err'), <<'DIAG', " blank lines get escaped" ); # foo # # bar DIAG $test->diag("foo\n\nbar\n\n"); is( $test->read('err'), <<'DIAG', " even at the end" ); # foo # # bar # DIAG } # [rt.cpan.org 8392] diag(@list) emulates print { $test->diag(qw(one two)); is( $test->read('err'), <<'DIAG' ); # onetwo DIAG } skip.t100644001750001750 365514772042322 17330 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 17; # If we skip with the same name, Test::Harness will report it back and # we won't get lots of false bug reports. my $Why = "Just testing the skip interface."; SKIP: { skip $Why, 2 unless Pigs->can('fly'); my $pig = Pigs->new; $pig->takeoff; ok( $pig->altitude > 0, 'Pig is airborne' ); ok( $pig->airspeed > 0, ' and moving' ); } SKIP: { skip "We're not skipping", 2 if 0; pass("Inside skip block"); pass("Another inside"); } SKIP: { skip "Again, not skipping", 2 if 0; my($pack, $file, $line) = caller; is( $pack || '', '', 'calling package not interfered with' ); is( $file || '', '', ' or file' ); is( $line || '', '', ' or line' ); } SKIP: { skip $Why, 2 if 1; die "A horrible death"; fail("Deliberate failure"); fail("And again"); } { my $warning; local $SIG{__WARN__} = sub { $warning = join "", @_ }; SKIP: { # perl gets the line number a little wrong on the first # statement inside a block. 1 == 1; #line 56 skip $Why; fail("So very failed"); } is( $warning, "skip() needs to know \$how_many tests are in the ". "block at $0 line 56\n", 'skip without $how_many warning' ); } SKIP: { skip "Not skipping here.", 4 if 0; pass("This is supposed to run"); # Testing out nested skips. SKIP: { skip $Why, 2; fail("AHHH!"); fail("You're a failure"); } pass("This is supposed to run, too"); } { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= join "", @_ }; SKIP: { skip 1, "This is backwards" if 1; pass "This does not run"; } like $warning, qr/^skip\(\) was passed a non-numeric number of tests/; } TieOut.pm100644001750001750 56414772042322 17262 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libpackage TieOut; use strict; sub TIEHANDLE { my $scalar = ''; bless( \$scalar, $_[0] ); } sub PRINT { my $self = shift; $$self .= join( '', @_ ); } sub PRINTF { my $self = shift; my $fmt = shift; $$self .= sprintf $fmt, @_; } sub FILENO { } sub read { my $self = shift; my $data = $$self; $$self = ''; return $data; } 1; MyTest.pm100644001750001750 17714772042322 17276 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libuse strict; use warnings; package MyTest; use Test::Builder; my $Test = Test::Builder->new; sub ok { $Test->ok(@_); } 1; SigDie.pm100644001750001750 11714772042322 17207 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libpackage SigDie; use strict; our $DIE; $SIG{__DIE__} = sub { $DIE = $@ }; 1; examples000755001750001750 014772042322 16173 5ustar00exodistexodist000000000000Test-Simple-1.302210tools.t100644001750001750 1107214772042322 17701 0ustar00exodistexodist000000000000Test-Simple-1.302210/examplesuse strict; use warnings; use Test2::IPC; BEGIN { require "t/tools.pl" }; use Test2::API qw/context intercept test2_stack/; ok(__PACKAGE__->can($_), "imported '$_\()'") for qw{ ok is isnt like unlike diag note is_deeply warnings exception plan skip_all done_testing }; ok(1, "'ok' Test"); is("foo", "foo", "'is' test"); is(undef, undef, "'is' undef test"); isnt("foo", "bar", "'isnt' test"); isnt("foo", undef, "'isnt' undef test 1"); isnt(undef, "foo", "'isnt' undef test 2"); like("foo", qr/o/, "'like' test"); unlike("foo", qr/a/, "'unlike' test"); diag("Testing Diag"); note("Testing Note"); my $str = "abc"; is_deeply( { a => 1, b => 2, c => { ref => \$str, obj => bless({x => 1}, 'XXX'), array => [1, 2, 3]}}, { a => 1, b => 2, c => { ref => \$str, obj => {x => 1}, array => [1, 2, 3]}}, "'is_deeply' test" ); is_deeply( warnings { warn "aaa\n"; warn "bbb\n" }, [ "aaa\n", "bbb\n" ], "Got warnings" ); is_deeply( warnings { 1 }, [], "no warnings" ); is(exception { die "foo\n" }, "foo\n", "got exception"); is(exception { 1 }, undef, "no exception"); my $events = intercept { plan 8; ok(0, "'ok' Test"); is("foo", "bar", "'is' test"); isnt("foo", "foo", "'isnt' test"); like("foo", qr/a/, "'like' test"); unlike("foo", qr/o/, "'unlike' test"); diag("Testing Diag"); note("Testing Note"); is_deeply( { a => 1, b => 2, c => {}}, { a => 1, b => 2, c => []}, "'is_deeply' test" ); }; is(@$events, 9, "got 9 events"); my ($plan, $ok, $is, $isnt, $like, $unlike, $diag, $note, $is_deeply) = @$events; ok($plan->isa('Test2::Event::Plan'), "got plan"); is($plan->max, 8, "planned for 8 oks"); ok($ok->isa('Test2::Event::Ok'), "got 'ok' result"); is($ok->pass, 0, "'ok' test failed"); ok($is->isa('Test2::Event::Ok'), "got 'is' result"); is($is->pass, 0, "'is' test failed"); ok($isnt->isa('Test2::Event::Ok'), "got 'isnt' result"); is($isnt->pass, 0, "'isnt' test failed"); ok($like->isa('Test2::Event::Ok'), "got 'like' result"); is($like->pass, 0, "'like' test failed"); ok($unlike->isa('Test2::Event::Ok'), "got 'unlike' result"); is($unlike->pass, 0, "'unlike' test failed"); ok($is_deeply->isa('Test2::Event::Ok'), "got 'is_deeply' result"); is($is_deeply->pass, 0, "'is_deeply' test failed"); ok($diag->isa('Test2::Event::Diag'), "got 'diag' result"); is($diag->message, "Testing Diag", "got diag message"); ok($note->isa('Test2::Event::Note'), "got 'note' result"); is($note->message, "Testing Note", "got note message"); $events = intercept { skip_all 'because'; ok(0, "should not see me"); die "should not happen"; }; is(@$events, 1, "1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "got plan"); is($events->[0]->directive, 'SKIP', "plan is skip"); is($events->[0]->reason, 'because', "skip reason"); $events = intercept { is(undef, ""); is("", undef); isnt(undef, undef); like(undef, qr//); unlike(undef, qr//); }; is(@$events, 5, "5 events"); ok(!$_->pass, "undef test - should not pass") for @$events; sub tool { context() }; my %params; my $ctx = context(level => -1); my $ictx; $events = intercept { %params = @_; $ictx = tool(); $ictx->ok(1, 'pass'); $ictx->ok(0, 'fail'); my $trace = Test2::Context::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__], ); $ictx->hub->finalize($trace, 1); }; is_deeply( \%params, { context => $ctx, hub => $ictx->hub, }, "Passed in some useful params" ); ok($ctx != $ictx, "Different context inside intercept"); is(@$events, 3, "got 3 events"); $ctx->release; $ictx->release; # Test that a bail-out in an intercept does not exit. $events = intercept { $ictx = tool(); $ictx->bail("The world ends"); $ictx->ok(0, "Should not see this"); }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Bail'), "got the bail"); $events = intercept { $ictx = tool(); }; $ictx->release; like( exception { intercept { die 'foo' } }, qr/foo/, "Exception was propagated" ); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); done_testing; }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); done_testing; API.pm100644001750001750 14531414772042322 17303 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::API; use strict; use warnings; use Time::HiRes qw/time/; use Test2::Util qw/USE_THREADS/; BEGIN { $ENV{TEST_ACTIVE} ||= 1; $ENV{TEST2_ACTIVE} = 1; } our $VERSION = '1.302210'; my $INST; my $ENDING = 0; sub test2_unset_is_end { $ENDING = 0 } sub test2_get_is_end { $ENDING } sub test2_set_is_end { my $before = $ENDING; ($ENDING) = @_ ? @_ : (1); # Only send the event in a transition from false to true return if $before; return unless $ENDING; return unless $INST; my $stack = $INST->stack or return; my $root = $stack->root or return; return unless $root->count; return unless $$ == $INST->pid; return unless get_tid() == $INST->tid; my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, __LINE__, __PACKAGE__ . '::test2_set_is_end'], ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $root, ); $ctx->send_ev2(control => { phase => 'END', details => 'Transition to END phase' }); 1; } use Test2::API::Instance(\$INST); # Set the exit status END { test2_set_is_end(); # See gh #16 $INST->set_exit(); } sub CLONE { my $init = test2_init_done(); my $load = test2_load_done(); return if $init && $load; require Carp; Carp::croak "Test2 must be fully loaded before you start a new thread!\n"; } # See gh #16 { no warnings; INIT { eval 'END { test2_set_is_end() }; 1' or die $@ } } BEGIN { no warnings 'once'; if("$]" >= 5.014 || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) { *DO_DEPTH_CHECK = sub() { 1 }; } else { *DO_DEPTH_CHECK = sub() { 0 }; } } use Test2::EventFacet::Trace(); use Test2::Util::Trace(); # Legacy use Test2::Hub::Subtest(); use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); use Test2::Event::Ok(); use Test2::Event::Diag(); use Test2::Event::Note(); use Test2::Event::Plan(); use Test2::Event::Bail(); use Test2::Event::Exception(); use Test2::Event::Waiting(); use Test2::Event::Skip(); use Test2::Event::Subtest(); use Carp qw/carp croak confess/; use Scalar::Util qw/blessed weaken/; use Test2::Util qw/get_tid clone_io pkg_to_file gen_uid/; our @EXPORT_OK = qw{ context release context_do no_context intercept intercept_deep run_subtest test2_init_done test2_load_done test2_load test2_start_preload test2_stop_preload test2_in_preload test2_is_testing_done test2_set_is_end test2_unset_is_end test2_get_is_end test2_pid test2_tid test2_stack test2_no_wait test2_ipc_wait_enable test2_ipc_wait_disable test2_ipc_wait_enabled test2_add_uuid_via test2_add_callback_testing_done test2_add_callback_context_aquire test2_add_callback_context_acquire test2_add_callback_context_init test2_add_callback_context_release test2_add_callback_exit test2_add_callback_post_load test2_add_callback_pre_subtest test2_list_context_aquire_callbacks test2_list_context_acquire_callbacks test2_list_context_init_callbacks test2_list_context_release_callbacks test2_list_exit_callbacks test2_list_post_load_callbacks test2_list_pre_subtest_callbacks test2_ipc test2_has_ipc test2_ipc_disable test2_ipc_disabled test2_ipc_drivers test2_ipc_add_driver test2_ipc_polling test2_ipc_disable_polling test2_ipc_enable_polling test2_ipc_get_pending test2_ipc_set_pending test2_ipc_get_timeout test2_ipc_set_timeout test2_formatter test2_formatters test2_formatter_add test2_formatter_set test2_stdout test2_stderr test2_reset_io test2_enable_trace_stamps test2_disable_trace_stamps test2_trace_stamps_enabled test2_add_pending_diag test2_get_pending_diags test2_clear_pending_diags }; BEGIN { require Exporter; our @ISA = qw(Exporter) } my @PENDING_DIAGS; sub test2_add_pending_diag { push @PENDING_DIAGS => @_ } sub test2_get_pending_diags { @PENDING_DIAGS } sub test2_clear_pending_diags { my @out = @PENDING_DIAGS; @PENDING_DIAGS = (); return @out } my $STACK = $INST->stack; my $CONTEXTS = $INST->contexts; my $INIT_CBS = $INST->context_init_callbacks; my $ACQUIRE_CBS = $INST->context_acquire_callbacks; my $STDOUT = clone_io(\*STDOUT); my $STDERR = clone_io(\*STDERR); sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) } sub test2_stderr { $STDERR ||= clone_io(\*STDERR) } sub test2_post_preload_reset { test2_reset_io(); $INST->post_preload_reset; } sub test2_reset_io { $STDOUT = clone_io(\*STDOUT); $STDERR = clone_io(\*STDERR); } sub test2_init_done { $INST->finalized } sub test2_load_done { $INST->loaded } sub test2_load { $INST->load } sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload } sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload } sub test2_in_preload { $INST->preload } sub test2_pid { $INST->pid } sub test2_tid { $INST->tid } sub test2_stack { $INST->stack } sub test2_ipc_wait_enable { $INST->set_no_wait(0) } sub test2_ipc_wait_disable { $INST->set_no_wait(1) } sub test2_ipc_wait_enabled { !$INST->no_wait } sub test2_enable_trace_stamps { $INST->test2_enable_trace_stamps } sub test2_disable_trace_stamps { $INST->test2_disable_trace_stamps } sub test2_trace_stamps_enabled { $INST->test2_trace_stamps_enabled } sub test2_is_testing_done { # No instance? VERY DONE! return 1 unless $INST; # No stack? tests must be done, it is created pretty early my $stack = $INST->stack or return 1; # Nothing on the stack, no root hub yet, likely have not started testing return 0 unless @$stack; # Stack has a slot for the root hub (see above) but it is undefined, likely # garbage collected, test is done my $root_hub = $stack->[0] or return 1; # If the root hub is ended than testing is done. return 1 if $root_hub->ended; # Looks like we are still testing! return 0; } sub test2_no_wait { $INST->set_no_wait(@_) if @_; $INST->no_wait; } sub test2_add_callback_testing_done { my $cb = shift; test2_add_callback_post_load(sub { my $stack = test2_stack(); $stack->top; # Ensure we have a hub my ($hub) = Test2::API::test2_stack->all; $hub->set_active(1); $hub->follow_up($cb); }); return; } sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) } sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) } sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) } sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) } sub test2_add_callback_exit { $INST->add_exit_callback(@_) } sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) } sub test2_add_callback_pre_subtest { $INST->add_pre_subtest_callback(@_) } sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} } sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} } sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} } sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} } sub test2_list_exit_callbacks { @{$INST->exit_callbacks} } sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} } sub test2_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} } sub test2_add_uuid_via { $INST->set_add_uuid_via(@_) if @_; $INST->add_uuid_via(); } sub test2_ipc { $INST->ipc } sub test2_has_ipc { $INST->has_ipc } sub test2_ipc_disable { $INST->ipc_disable } sub test2_ipc_disabled { $INST->ipc_disabled } sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) } sub test2_ipc_drivers { @{$INST->ipc_drivers} } sub test2_ipc_polling { $INST->ipc_polling } sub test2_ipc_enable_polling { $INST->enable_ipc_polling } sub test2_ipc_disable_polling { $INST->disable_ipc_polling } sub test2_ipc_get_pending { $INST->get_ipc_pending } sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } sub test2_ipc_set_timeout { $INST->set_ipc_timeout(@_) } sub test2_ipc_get_timeout { $INST->ipc_timeout() } sub test2_ipc_enable_shm { 0 } sub test2_formatter { if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { my $formatter = $1 ? $2 : "Test2::Formatter::$2"; my $file = pkg_to_file($formatter); require $file; return $formatter; } return $INST->formatter; } sub test2_formatters { @{$INST->formatters} } sub test2_formatter_add { $INST->add_formatter(@_) } sub test2_formatter_set { my ($formatter) = @_; croak "No formatter specified" unless $formatter; croak "Global Formatter already set" if $INST->formatter_set; $INST->set_formatter($formatter); } # Private, for use in Test2::API::Context sub _contexts_ref { $INST->contexts } sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks } sub _context_init_callbacks_ref { $INST->context_init_callbacks } sub _context_release_callbacks_ref { $INST->context_release_callbacks } sub _add_uuid_via_ref { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) } # Private, for use in Test2::IPC sub _set_ipc { $INST->set_ipc(@_) } sub context_do(&;@) { my $code = shift; my @args = @_; my $ctx = context(level => 1); my $want = wantarray; my @out; my $ok = eval { $want ? @out = $code->($ctx, @args) : defined($want) ? $out[0] = $code->($ctx, @args) : $code->($ctx, @args) ; 1; }; my $err = $@; $ctx->release; die $err unless $ok; return @out if $want; return $out[0] if defined $want; return; } sub no_context(&;$) { my ($code, $hid) = @_; $hid ||= $STACK->top->hid; my $ctx = $CONTEXTS->{$hid}; delete $CONTEXTS->{$hid}; my $ok = eval { $code->(); 1 }; my $err = $@; $CONTEXTS->{$hid} = $ctx; weaken($CONTEXTS->{$hid}); die $err unless $ok; return; }; my $UUID_VIA = _add_uuid_via_ref(); sub context { # We need to grab these before anything else to ensure they are not # changed. my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E); my %params = (level => 0, wrapped => 0, @_); # If something is getting a context then the sync system needs to be # considered loaded... $INST->load unless $INST->{loaded}; croak "context() called, but return value is ignored" unless defined wantarray; my $stack = $params{stack} || $STACK; my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); # Catch an edge case where we try to get context after the root hub has # been garbage collected resulting in a stack that has a single undef # hub if (!($hub && $hub->{hid}) && !exists($params{hub}) && @$stack) { my $msg; if ($hub && !$hub->{hid}) { $msg = Carp::longmess("$hub has no hid! (did you attempt a testing event after done_testing?). You may be relying on a tool or plugin that was based off an old Test2 that did not require hids."); } else { $msg = Carp::longmess("Attempt to get Test2 context after testing has completed (did you attempt a testing event after done_testing?)"); } # The error message is usually masked by the global destruction, so we have to print to STDER print STDERR $msg; # Make sure this is a failure, we are probably already in END, so set $? to change the exit code $? = 1; # Now we actually die to interrupt the program flow and avoid undefined his warnings die $msg; } my $hid = $hub->{hid}; my $current = $CONTEXTS->{$hid}; $_->(\%params) for @$ACQUIRE_CBS; map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire}; # This is for https://github.com/Test-More/test-more/issues/16 # and https://rt.perl.org/Public/Bug/Display.html?id=127774 my $phase = ${^GLOBAL_PHASE} || 'NA'; my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT'; my $level = 1 + $params{level}; my ($pkg, $file, $line, $sub, @other) = $end_phase ? caller(0) : caller($level); unless ($pkg || $end_phase) { confess "Could not find context at depth $level" unless $params{fudge}; ($pkg, $file, $line, $sub, @other) = caller(--$level) while ($level >= 0 && !$pkg); } my $depth = $level; $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1); $depth -= $params{wrapped}; my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth; if ($current && $params{on_release} && $depth_ok) { $current->{_on_release} ||= []; push @{$current->{_on_release}} => $params{on_release}; } # I know this is ugly.... ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error) and return bless( { %$current, _is_canon => undef, errno => $errno, eval_error => $eval_error, child_error => $child_error, _is_spawn => [$pkg, $file, $line, $sub], _start_fail_count => $hub->{failed} || 0, }, 'Test2::API::Context' ) if $current && $depth_ok; # Handle error condition of bad level if ($current) { unless (${$current->{_aborted}}) { _canon_error($current, [$pkg, $file, $line, $sub, $depth]) unless $current->{_is_canon}; _depth_error($current, [$pkg, $file, $line, $sub, $depth]) unless $depth_ok; } $current->release if $current->{_is_canon}; delete $CONTEXTS->{$hid}; } # Directly bless the object here, calling new is a noticeable performance # hit with how often this needs to be called. my $trace = bless( { frame => [$pkg, $file, $line, $sub], pid => $$, tid => get_tid(), cid => gen_uid(), hid => $hid, nested => $hub->{nested}, buffered => $hub->{buffered}, full_caller => [$pkg, $file, $line, $sub, @other], $INST->{trace_stamps} ? (stamp => time()) : (), $$UUID_VIA ? ( huuid => $hub->{uuid}, uuid => ${$UUID_VIA}->('context'), ) : (), }, 'Test2::EventFacet::Trace' ); # Directly bless the object here, calling new is a noticeable performance # hit with how often this needs to be called. my $aborted = 0; $current = bless( { _aborted => \$aborted, stack => $stack, hub => $hub, trace => $trace, _is_canon => 1, _depth => $depth, errno => $errno, eval_error => $eval_error, child_error => $child_error, _start_fail_count => $hub->{failed} || 0, $params{on_release} ? (_on_release => [$params{on_release}]) : (), }, 'Test2::API::Context' ); $CONTEXTS->{$hid} = $current; weaken($CONTEXTS->{$hid}); $_->($current) for @$INIT_CBS; map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init}; $params{on_init}->($current) if $params{on_init}; ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error); return $current; } sub _depth_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context was created in a stack frame at the same, or deeper level. This usually means that a tool failed to release the context when it was finished. EOT } sub _canon_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context has an invalid internal state (!_canon_count). This should not normally happen unless something is mucking about with internals... EOT } sub _existing_error { my ($ctx, $details, $msg) = @_; my ($pkg, $file, $line, $sub, $depth) = @$details; my $oldframe = $ctx->{trace}->frame; my $olddepth = $ctx->{_depth}; # Older versions of Carp do not export longmess() function, so it needs to be called with package name my $mess = Carp::longmess(); warn <<" EOT"; $msg Old context details: File: $oldframe->[1] Line: $oldframe->[2] Tool: $oldframe->[3] Depth: $olddepth New context details: File: $file Line: $line Tool: $sub Depth: $depth Trace: $mess Removing the old context and creating a new one... EOT } sub release($;$) { $_[0]->release; return $_[1]; } sub intercept(&) { my $code = shift; my $ctx = context(); my $events = _intercept($code, deep => 0); $ctx->release; return $events; } sub intercept_deep(&) { my $code = shift; my $ctx = context(); my $events = _intercept($code, deep => 1); $ctx->release; return $events; } sub _intercept { my $code = shift; my %params = @_; my $ctx = context(); my $ipc; if (my $global_ipc = test2_ipc()) { my $driver = blessed($global_ipc); $ipc = $driver->new; } my $hub = Test2::Hub::Interceptor->new( ipc => $ipc, no_ending => 1, ); my @events; $hub->listen(sub { push @events => $_[1] }, inherit => $params{deep}); $ctx->stack->top; # Make sure there is a top hub before we begin. $ctx->stack->push($hub); my $trace = $ctx->trace; my $state = {}; $hub->clean_inherited(trace => $trace, state => $state); my ($ok, $err) = (1, undef); T2_SUBTEST_WRAPPER: { # Do not use 'try' cause it localizes __DIE__ $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 }; $err = $@; # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) { $ok = 1; $err = undef; } } $hub->cull; $ctx->stack->pop($hub); $hub->restore_inherited(trace => $trace, state => $state); $ctx->release; die $err unless $ok; $hub->finalize($trace, 1) if $ok && !$hub->no_ending && !$hub->ended; require Test2::API::InterceptResult; return Test2::API::InterceptResult->new_from_ref(\@events); } sub run_subtest { my ($name, $code, $params, @args) = @_; $_->($name,$code,@args) for Test2::API::test2_list_pre_subtest_callbacks(); $params = {buffered => $params} unless ref $params; my $inherit_trace = delete $params->{inherit_trace}; my $ctx = context(); my $parent = $ctx->hub; # If a parent is buffered then the child must be as well. my $buffered = $params->{buffered} || $parent->{buffered}; $ctx->note($name) unless $buffered; my $stack = $ctx->stack || $STACK; my $hub = $stack->new_hub( class => 'Test2::Hub::Subtest', %$params, buffered => $buffered, ); my @events; $hub->listen(sub { push @events => $_[1] }); if ($buffered) { if (my $format = $hub->format) { my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1; $hub->format(undef) if $hide; } } if ($inherit_trace) { my $orig = $code; $code = sub { my $base_trace = $ctx->trace; my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested); my $st_ctx = Test2::API::Context->new( trace => $trace, hub => $hub, ); $st_ctx->do_in_context($orig, @args); }; } my $start_stamp = time; my ($ok, $err, $finished); T2_SUBTEST_WRAPPER: { # Do not use 'try' cause it localizes __DIE__ $ok = eval { $code->(@args); 1 }; $err = $@; # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { $ok = undef; $err = undef; } else { $finished = 1; } } my $stop_stamp = time; if ($params->{no_fork}) { if ($$ != $ctx->trace->pid) { warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; exit 255; } if (get_tid() != $ctx->trace->tid) { warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err; exit 255; } } elsif (!$parent->is_local && !$parent->ipc) { warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err; exit 255; } $stack->pop($hub); my $trace = $ctx->trace; my $bailed = $hub->bailed_out; if (!$finished) { if ($bailed && !$buffered) { $ctx->bail($bailed->reason); } elsif ($bailed && $buffered) { $ok = 1; } else { my $code = $hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } } $hub->finalize($trace->snapshot(huuid => $hub->uuid, hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1) if $ok && !$hub->no_ending && !$hub->ended; my $pass = $ok && $hub->is_passing; my $e = $ctx->build_event( 'Subtest', pass => $pass, name => $name, subtest_id => $hub->id, subtest_uuid => $hub->uuid, buffered => $buffered, subevents => \@events, start_stamp => $start_stamp, stop_stamp => $stop_stamp, ); my $plan_ok = $hub->check_plan; $ctx->hub->send($e); $ctx->failure_diag($e) unless $e->pass; $ctx->diag("Caught exception in subtest: $err") unless $ok; $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) if defined($plan_ok) && !$plan_ok; $ctx->bail($bailed->reason) if $bailed && $buffered; $ctx->release; return $pass; } # There is a use-cycle between API and API/Context. Context needs to use some # API functions as the package is compiling. Test2::API::context() needs # Test2::API::Context to be loaded, but we cannot 'require' the module there as # it causes a very noticeable performance impact with how often context() is # called. require Test2::API::Context; # If the env var was set to load plugins, load them now, this is the earliest # safe point to do so. if (my $plugins = $ENV{TEST2_ENABLE_PLUGINS}) { for my $p (split /\s*,\s*/, $plugins) { $p = "Test2::Plugin::$p" unless $p =~ s/^\+//; my $mod = "$p.pm"; $mod =~ s{::}{/}g; 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__, $p]), message => "Loaded plugin '$p' as specified in the TEST2_ENABLE_PLUGINS env var.", ), ); }); } eval { package main; require $mod; $p->import; 1 } or die "Could not load plugin '$p', which was specified in the TEST2_ENABLE_PLUGINS env var ($plugins): $@"; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API - Primary interface for writing Test2 based testing tools. =head1 ***INTERNALS NOTE*** B The public methods provided will not change in backwards-incompatible ways (once there is a stable release), but the underlying implementation details might. B Currently the implementation is to create a single instance of the L Object. All class methods defer to the single instance. There is no public access to the singleton, and that is intentional. The class methods provided by this package provide the only functionality publicly exposed. This is done primarily to avoid the problems Test::Builder had by exposing its singleton. We do not want anyone to replace this singleton, rebless it, or directly muck with its internals. If you need to do something and cannot because of the restrictions placed here, then please report it as an issue. If possible, we will create a way for you to implement your functionality without exposing things that should not be exposed. =head1 DESCRIPTION This package exports all the functions necessary to write and/or verify testing tools. Using these building blocks you can begin writing test tools very quickly. You are also provided with tools that help you to test the tools you write. =head1 SYNOPSIS =head2 WRITING A TOOL The C method is your primary interface into the Test2 framework. package My::Ok; use Test2::API qw/context/; our @EXPORT = qw/my_ok/; use base 'Exporter'; # Just like ok() from Test::More sub my_ok($;$) { my ($bool, $name) = @_; my $ctx = context(); # Get a context $ctx->ok($bool, $name); $ctx->release; # Release the context return $bool; } See L for a list of methods available on the context object. =head2 TESTING YOUR TOOLS The C tool lets you temporarily intercept all events generated by the test system: use Test2::API qw/intercept/; use My::Ok qw/my_ok/; my $events = intercept { # These events are not displayed my_ok(1, "pass"); my_ok(0, "fail"); }; As of version 1.302178 this now returns an arrayref that is also an instance of L. See the L documentation for details on how to best use it. =head2 OTHER API FUNCTIONS use Test2::API qw{ test2_init_done test2_stack test2_set_is_end test2_get_is_end test2_ipc test2_formatter_set test2_formatter test2_is_testing_done }; my $init = test2_init_done(); my $stack = test2_stack(); my $ipc = test2_ipc(); test2_formatter_set($FORMATTER) my $formatter = test2_formatter(); ... And others ... =head1 ENVIRONMENT VARIABLES See L for a list of meaningul environment variables. =head1 MAIN API EXPORTS All exports are optional. You must specify subs to import. use Test2::API qw/context intercept run_subtest/; This is the list of exports that are most commonly needed. If you are simply writing a tool, then this is probably all you need. If you need something and you cannot find it here, then you can also look at L. These exports lack the 'test2_' prefix because of how important/common they are. Exports in the L section have the 'test2_' prefix to ensure they stand out. =head2 context(...) Usage: =over 4 =item $ctx = context() =item $ctx = context(%params) =back The C function will always return the current context. If there is already a context active, it will be returned. If there is not an active context, one will be generated. When a context is generated it will default to using the file and line number where the currently running sub was called from. Please see L for important rules about what you can and cannot do with a context once it is obtained. B This function will throw an exception if you ignore the context object it returns. B On perls 5.14+ a depth check is used to ensure there are no context leaks. This cannot be safely done on older perls due to L You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or C<$Test2::API::DO_DEPTH_CHECK = 1> B loading L. =head3 OPTIONAL PARAMETERS All parameters to C are optional. =over 4 =item level => $int If you must obtain a context in a sub deeper than your entry point you can use this to tell it how many EXTRA stack frames to look back. If this option is not provided the default of C<0> is used. sub third_party_tool { my $sub = shift; ... # Does not obtain a context $sub->(); ... } third_party_tool(sub { my $ctx = context(level => 1); ... $ctx->release; }); =item wrapped => $int Use this if you need to write your own tool that wraps a call to C with the intent that it should return a context object. sub my_context { my %params = ( wrapped => 0, @_ ); $params{wrapped}++; my $ctx = context(%params); ... return $ctx; } sub my_tool { my $ctx = my_context(); ... $ctx->release; } If you do not do this, then tools you call that also check for a context will notice that the context they grabbed was created at the same stack depth, which will trigger protective measures that warn you and destroy the existing context. =item stack => $stack Normally C looks at the global hub stack. If you are maintaining your own L instance you may pass it in to be used instead of the global one. =item hub => $hub Use this parameter if you want to obtain the context for a specific hub instead of whatever one happens to be at the top of the stack. =item on_init => sub { ... } This lets you provide a callback sub that will be called B if your call to C generated a new context. The callback B be called if C is returning an existing context. The only argument passed into the callback will be the context object itself. sub foo { my $ctx = context(on_init => sub { 'will run' }); my $inner = sub { # This callback is not run since we are getting the existing # context from our parent sub. my $ctx = context(on_init => sub { 'will NOT run' }); $ctx->release; } $inner->(); $ctx->release; } =item on_release => sub { ... } This lets you provide a callback sub that will be called when the context instance is released. This callback will be added to the returned context even if an existing context is returned. If multiple calls to context add callbacks, then all will be called in reverse order when the context is finally released. sub foo { my $ctx = context(on_release => sub { 'will run second' }); my $inner = sub { my $ctx = context(on_release => sub { 'will run first' }); # Neither callback runs on this release $ctx->release; } $inner->(); # Both callbacks run here. $ctx->release; } =back =head2 release($;$) Usage: =over 4 =item release $ctx; =item release $ctx, ...; =back This is intended as a shortcut that lets you release your context and return a value in one statement. This function will get your context, and an optional return value. It will release your context, then return your value. Scalar context is always assumed. sub tool { my $ctx = context(); ... return release $ctx, 1; } This tool is most useful when you want to return the value you get from calling a function that needs to see the current context: my $ctx = context(); my $out = some_tool(...); $ctx->release; return $out; We can combine the last 3 lines of the above like so: my $ctx = context(); release $ctx, some_tool(...); =head2 context_do(&;@) Usage: sub my_tool { context_do { my $ctx = shift; my (@args) = @_; $ctx->ok(1, "pass"); ... # No need to call $ctx->release, done for you on scope exit. } @_; } Using this inside your test tool takes care of a lot of boilerplate for you. It will ensure a context is acquired. It will capture and rethrow any exception. It will ensure the context is released when you are done. It preserves the subroutine call context (list, scalar, void). This is the safest way to write a test tool. The only two downsides to this are a slight performance decrease, and some extra indentation in your source. If the indentation is a problem for you then you can take a peek at the next section. =head2 no_context(&;$) Usage: =over 4 =item no_context { ... }; =item no_context { ... } $hid; sub my_tool(&) { my $code = shift; my $ctx = context(); ... no_context { # Things in here will not see our current context, they get a new # one. $code->(); }; ... $ctx->release; }; =back This tool will hide a context for the provided block of code. This means any tools run inside the block will get a completely new context if they acquire one. The new context will be inherited by tools nested below the one that acquired it. This will normally hide the current context for the top hub. If you need to hide the context for a different hub you can pass in the optional C<$hid> parameter. =head2 intercept(&) Usage: my $events = intercept { ok(1, "pass"); ok(0, "fail"); ... }; This function takes a codeblock as its only argument, and it has a prototype. It will execute the codeblock, intercepting any generated events in the process. It will return an array reference with all the generated event objects. All events should be subclasses of L. As of version 1.302178 the events array that is returned is blssed as an L instance. L Provides a helpful interface for filtering and/or inspecting the events list overall, or individual events within the list. This is intended to help you test your test code. This is not intended for people simply writing tests. =head2 run_subtest(...) Usage: run_subtest($NAME, \&CODE, $BUFFERED, @ARGS) # or run_subtest($NAME, \&CODE, \%PARAMS, @ARGS) This will run the provided codeblock with the args in C<@args>. This codeblock will be run as a subtest. A subtest is an isolated test state that is condensed into a single L event, which contains all events generated inside the subtest. =head3 ARGUMENTS: =over 4 =item $NAME The name of the subtest. =item \&CODE The code to run inside the subtest. =item $BUFFERED or \%PARAMS If this is a simple scalar then it will be treated as a boolean for the 'buffered' setting. If this is a hash reference then it will be used as a parameters hash. The param hash will be used for hub construction (with the specified keys removed). Keys that are removed and used by run_subtest: =over 4 =item 'buffered' => $bool Toggle buffered status. =item 'inherit_trace' => $bool Normally the subtest hub is pushed and the sub is allowed to generate its own root context for the hub. When this setting is turned on a root context will be created for the hub that shares the same trace as the current context. Set this to true if your tool is producing subtests without user-specified subs. =item 'no_fork' => $bool Defaults to off. Normally forking inside a subtest will actually fork the subtest, resulting in 2 final subtest events. This parameter will turn off that behavior, only the original process/thread will return a final subtest event. =back =item @ARGS Any extra arguments you want passed into the subtest code. =back =head3 BUFFERED VS UNBUFFERED (OR STREAMED) Normally all events inside and outside a subtest are sent to the formatter immediately by the hub. Sometimes it is desirable to hold off sending events within a subtest until the subtest is complete. This usually depends on the formatter being used. =over 4 =item Things not affected by this flag In both cases events are generated and stored in an array. This array is eventually used to populate the C attribute on the L event that is generated at the end of the subtest. This flag has no effect on this part; it always happens. At the end of the subtest, the final L event is sent to the formatter. =item Things that are affected by this flag The C attribute of the L event will be set to the value of this flag. This means any formatter, listener, etc which looks at the event will know if it was buffered. =item Things that are formatter dependent Events within a buffered subtest may or may not be sent to the formatter as they happen. If a formatter fails to specify then the default is to B the events as they are generated, instead the formatter can pull them from the C attribute. A formatter can specify by implementing the C method. If this method returns true then events generated inside a buffered subtest will not be sent independently of the final subtest event. =back An example of how this is used is the L formatter. For unbuffered subtests the events are rendered as they are generated. At the end of the subtest, the final subtest event is rendered, but the C attribute is ignored. For buffered subtests the opposite occurs, the events are NOT rendered as they are generated, instead the C attribute is used to render them all at once. This is useful when running subtests tests in parallel, since without it the output from subtests would be interleaved together. =head1 OTHER API EXPORTS Exports in this section are not commonly needed. These all have the 'test2_' prefix to help ensure they stand out. You should look at the L section before looking here. This section is one where "Great power comes with great responsibility". It is possible to break things badly if you are not careful with these. All exports are optional. You need to list which ones you want at import time: use Test2::API qw/test2_init_done .../; =head2 STATUS AND INITIALIZATION STATE These provide access to internal state and object instances. =over 4 =item $bool = test2_init_done() This will return true if the stack and IPC instances have already been initialized. It will return false if they have not. Init happens as late as possible. It happens as soon as a tool requests the IPC instance, the formatter, or the stack. =item $bool = test2_load_done() This will simply return the boolean value of the loaded flag. If Test2 has finished loading this will be true, otherwise false. Loading is considered complete the first time a tool requests a context. =item test2_set_is_end() =item test2_set_is_end($bool) This is used to toggle Test2's belief that the END phase has already started. With no arguments this will set it to true. With arguments it will set it to the first argument's value. This is used to prevent the use of C in END blocks which can cause segfaults. This is only necessary in some persistent environments that may have multiple END phases. =item $bool = test2_get_is_end() Check if Test2 believes it is the END phase. =item $stack = test2_stack() This will return the global L instance. If this has not yet been initialized it will be initialized now. =item $bool = test2_is_testing_done() This will return true if testing is complete and no other events should be sent. This is useful in things like warning handlers where you might want to turn warnings into events, but need them to start acting like normal warnings when testing is done. $SIG{__WARN__} = sub { my ($warning) = @_; if (test2_is_testing_done()) { warn @_; } else { my $ctx = context(); ... $ctx->release } } =item test2_ipc_disable Disable IPC. =item $bool = test2_ipc_disabled Check if IPC is disabled. =item test2_ipc_wait_enable() =item test2_ipc_wait_disable() =item $bool = test2_ipc_wait_enabled() These can be used to turn IPC waiting on and off, or check the current value of the flag. Waiting is turned on by default. Waiting will cause the parent process/thread to wait until all child processes and threads are finished before exiting. You will almost never want to turn this off. =item $bool = test2_no_wait() =item test2_no_wait($bool) B: This is a confusing interface, it is better to use C, C and C. This can be used to get/set the no_wait status. Waiting is turned on by default. Waiting will cause the parent process/thread to wait until all child processes and threads are finished before exiting. You will almost never want to turn this off. =item $fh = test2_stdout() =item $fh = test2_stderr() These functions return the filehandles that test output should be written to. They are primarily useful when writing a custom formatter and code that turns events into actual output (TAP, etc.). They will return a dupe of the original filehandles that formatted output can be sent to regardless of whatever state the currently running test may have left STDOUT and STDERR in. =item test2_reset_io() Re-dupe the internal filehandles returned by C and C from the current STDOUT and STDERR. You shouldn't need to do this except in very peculiar situations (for example, you're testing a new formatter and you need control over where the formatter is sending its output.) =back =head2 BEHAVIOR HOOKS These are hooks that allow you to add custom behavior to actions taken by Test2 and tools built on top of it. =over 4 =item test2_add_callback_exit(sub { ... }) This can be used to add a callback that is called after all testing is done. This is too late to add additional results, the main use of this callback is to set the exit code. test2_add_callback_exit( sub { my ($context, $exit, \$new_exit) = @_; ... } ); The C<$context> passed in will be an instance of L. The C<$exit> argument will be the original exit code before anything modified it. C<$$new_exit> is a reference to the new exit code. You may modify this to change the exit code. Please note that C<$$new_exit> may already be different from C<$exit> =item test2_add_callback_post_load(sub { ... }) Add a callback that will be called when Test2 is finished loading. This means the callback will be run once, the first time a context is obtained. If Test2 has already finished loading then the callback will be run immediately. =item test2_add_callback_testing_done(sub { ... }) This adds your coderef as a follow-up to the root hub after Test2 is finished loading. This is essentially a helper to do the following: test2_add_callback_post_load(sub { my $stack = test2_stack(); $stack->top; # Ensure we have a hub my ($hub) = Test2::API::test2_stack->all; $hub->set_active(1); $hub->follow_up(sub { ... }); # <-- Your coderef here }); =item test2_add_callback_context_acquire(sub { ... }) Add a callback that will be called every time someone tries to acquire a context. This will be called on EVERY call to C. It gets a single argument, a reference to the hash of parameters being used the construct the context. This is your chance to change the parameters by directly altering the hash. test2_add_callback_context_acquire(sub { my $params = shift; $params->{level}++; }); This is a very scary API function. Please do not use this unless you need to. This is here for L and backwards compatibility. This has you directly manipulate the hash instead of returning a new one for performance reasons. =item test2_add_callback_context_init(sub { ... }) Add a callback that will be called every time a new context is created. The callback will receive the newly created context as its only argument. =item test2_add_callback_context_release(sub { ... }) Add a callback that will be called every time a context is released. The callback will receive the released context as its only argument. =item test2_add_callback_pre_subtest(sub { ... }) Add a callback that will be called every time a subtest is going to be run. The callback will receive the subtest name, coderef, and any arguments. =item @list = test2_list_context_acquire_callbacks() Return all the context acquire callback references. =item @list = test2_list_context_init_callbacks() Returns all the context init callback references. =item @list = test2_list_context_release_callbacks() Returns all the context release callback references. =item @list = test2_list_exit_callbacks() Returns all the exit callback references. =item @list = test2_list_post_load_callbacks() Returns all the post load callback references. =item @list = test2_list_pre_subtest_callbacks() Returns all the pre-subtest callback references. =item test2_add_uuid_via(sub { ... }) =item $sub = test2_add_uuid_via() This allows you to provide a UUID generator. If provided UUIDs will be attached to all events, hubs, and contexts. This is useful for storing, tracking, and linking these objects. The sub you provide should always return a unique identifier. Most things will expect a proper UUID string, however nothing in Test2::API enforces this. The sub will receive exactly 1 argument, the type of thing being tagged 'context', 'hub', or 'event'. In the future additional things may be tagged, in which case new strings will be passed in. These are purely informative, you can (and usually should) ignore them. =item test2_add_pending_diag($diag) =item test2_add_pending_diag($diag1, $diag2) Add a diagnostics message that will be issued the next time a context in which a failure occured is released. This can also be thought of like this: "If the next bit causes a failed assertion, add this diagnostics message". =item @diags = test2_get_pending_diags() Get all the current pending diagnostics messages. =item @diags = test2_clear_pending_diags() Clear any pending diagnostics, returning them. =back =head2 IPC AND CONCURRENCY These let you access, or specify, the IPC system internals. =over 4 =item $bool = test2_has_ipc() Check if IPC is enabled. =item $ipc = test2_ipc() This will return the global L instance. If this has not yet been initialized it will be initialized now. =item test2_ipc_add_driver($DRIVER) Add an IPC driver to the list. This will add the driver to the start of the list. =item @drivers = test2_ipc_drivers() Get the list of IPC drivers. =item $bool = test2_ipc_polling() Check if polling is enabled. =item test2_ipc_enable_polling() Turn on polling. This will cull events from other processes and threads every time a context is created. =item test2_ipc_disable_polling() Turn off IPC polling. =item test2_ipc_enable_shm() Legacy, this is currently a no-op that returns 0; =item test2_ipc_set_pending($uniq_val) Tell other processes and events that an event is pending. C<$uniq_val> should be a unique value no other thread/process will generate. B After calling this C will return 1. This is intentional, and not avoidable. =item $pending = test2_ipc_get_pending() This returns -1 if there is no way to check (assume yes) This returns 0 if there are (most likely) no pending events. This returns 1 if there are (likely) pending events. Upon return it will reset, nothing else will be able to see that there were pending events. =item $timeout = test2_ipc_get_timeout() =item test2_ipc_set_timeout($timeout) Get/Set the timeout value for the IPC system. This timeout is how long the IPC system will wait for child processes and threads to finish before aborting. The default value is C<30> seconds. =back =head2 MANAGING FORMATTERS These let you access, or specify, the formatters that can/should be used. =over 4 =item $formatter = test2_formatter This will return the global formatter class. This is not an instance. By default the formatter is set to L. You can override this default using the C environment variable. Normally 'Test2::Formatter::' is prefixed to the value in the environment variable: $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter If you want to specify a full module name you use the '+' prefix: $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter =item test2_formatter_set($class_or_instance) Set the global formatter class. This can only be set once. B This will override anything specified in the 'T2_FORMATTER' environment variable. =item @formatters = test2_formatters() Get a list of all loaded formatters. =item test2_formatter_add($class_or_instance) Add a formatter to the list. Last formatter added is used at initialization. If this is called after initialization a warning will be issued. =back =head2 TIME STAMPS You can enable or disable timestamps in trace facets. They are disabled by default for compatibility and performance reasons. =over 4 =item test2_enable_trace_stamps() Enable stamps in traces. =item test2_disable_trace_stamps() Disable stamps in traces. =item $bool = test2_trace_stamps_enabled() Check status of trace stamps. =back =head1 OTHER EXAMPLES See the C directory included in this distribution. =head1 SEE ALSO L - Detailed documentation of the context object. L - The IPC system used for threading/fork support. L - Formatters such as TAP live here. L - Events live in this namespace. L - All events eventually funnel through a hub. Custom hubs are how C and C are implemented. =head1 MAGIC This package has an END block. This END block is responsible for setting the exit code based on the test results. This end block also calls the callbacks that can be added to this package. =head1 SOURCE The source code repository for Test2 can be found at 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 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 Env.pm100644001750001750 616014772042322 17355 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Env; use strict; use warnings; our $VERSION = '1.302210'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Env - Documentation for environment variables used or set by Test2. =head1 DESCRIPTION This is a list of environment variables that are either set by, or read by Test2. =head1 AUTHOR_TESTING This env var is read by Test2. When set Test2 will run tests that are normally skipped unless a module author is doing extra author-specific testing. =head1 AUTOMATED_TESTING This env var is read by Test2. When set this indicates the tests are run by an automated system and no human interaction is possible. See L. =head1 EXTENDED_TESTING This env var is read by Test2. When set it indicates some extended testing that should normally be skipped will be run. See L. =head1 HARNESS_ACTIVE This env var is read by Test2. It is usually set by C (L) or C (L). =head1 NONINTERACTIVE_TESTING This env var is read by Test2. When set this indicates the testing will not be interactive. See L. =head1 RELEASE_TESTING This env var is read by Test2. When set this indicates that release testing is being done, which may run more tests than normal. See L. =head1 T2_FORMATTER This can be used to set the formatter that Test2 will use. If set to a string without a '+' prefix, then 'Test2::Formatter::' will be added to the start of the module name. If '+' is present it will be stripped and no further modification will be made to the module name. =head1 T2_IN_PRELOAD Test2 sets this when preload mode is active. This is mainly used by L and similar tools that preload Test2, then fork to run tests. =head1 TABLE_TERM_SIZE This is used to set a terminal width for things like diagnostic message tables. =head1 TEST2_ACTIVE Test2 sets this variable when tests are running. =head1 TEST2_ENABLE_PLUGINS This can be used to force plugins to be loaded whent he Test2 API is loaded. It takes a list of one or more plugin names seperated by comma. If the module name does not have a '+' in front of it then the C namespace is assumed and added. If a '+' is present at the start of a module name it will be stripped and no further modification will be made. Examples: TEST2_ENABLE_PLUGINS=BailOnFail Test2_ENABLE_PLUGINS=SRand,+My::Plugin::Name =head1 TEST_ACTIVE Set by Test2 when tests are running. =head1 TS_MAX_DELTA Used to determine how many max lines of output will be provided when is() finds a deep data strucgture mismatch. =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 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 IPC.pm100644001750001750 614314772042322 17241 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::IPC; use strict; use warnings; our $VERSION = '1.302210'; use Test2::API::Instance; use Test2::Util qw/get_tid/; use Test2::API qw{ test2_in_preload test2_init_done test2_ipc test2_has_ipc test2_ipc_enable_polling test2_pid test2_stack test2_tid context }; # Make sure stuff is finalized before anyone tried to fork or start a new thread. { # Avoid warnings if things are loaded at run-time no warnings 'void'; INIT { use warnings 'void'; context()->release() unless test2_in_preload(); } } use Carp qw/confess/; our @EXPORT_OK = qw/cull/; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub unimport { Test2::API::test2_ipc_disable() } sub import { goto &Exporter::import if test2_has_ipc || !test2_init_done(); confess "IPC is disabled" if Test2::API::test2_ipc_disabled(); confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$; confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid(); Test2::API::_set_ipc(_make_ipc()); apply_ipc(test2_stack()); goto &Exporter::import; } sub _make_ipc { # Find a driver my ($driver) = Test2::API::test2_ipc_drivers(); unless ($driver) { require Test2::IPC::Driver::Files; $driver = 'Test2::IPC::Driver::Files'; } return $driver->new(); } sub apply_ipc { my $stack = shift; my ($root) = @$stack; return unless $root; confess "Cannot add IPC in a child process" if $root->pid != $$; confess "Cannot add IPC in a child thread" if $root->tid != get_tid(); my $ipc = $root->ipc || test2_ipc() || _make_ipc(); # Add the IPC to all hubs for my $hub (@$stack) { my $has = $hub->ipc; confess "IPC Mismatch!" if $has && $has != $ipc; next if $has; $hub->set_ipc($ipc); $ipc->add_hub($hub->hid); } test2_ipc_enable_polling(); return $ipc; } sub cull { my $ctx = context(); $ctx->hub->cull; $ctx->release; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC - Turn on IPC for threading or forking support. =head1 SYNOPSIS You should C as early as possible in your test file. If you import this module after API initialization it will attempt to retrofit IPC onto the existing hubs. =head2 DISABLING IT You can use C to disable IPC for good. You can also use the T2_NO_IPC env var. =head1 EXPORTS All exports are optional. =over 4 =item cull() Cull allows you to collect results from other processes or threads on demand. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Hub.pm100644001750001750 5444614772042322 17375 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Hub; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/carp croak confess/; use Test2::Util qw/get_tid gen_uid/; use Scalar::Util qw/weaken/; use List::Util qw/first/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ pid tid hid ipc nested buffered no_ending _filters _pre_filters _listeners _follow_ups _formatter _context_acquire _context_init _context_release uuid active count failed ended bailed_out _passing _plan skip_reason }; my $UUID_VIA; sub init { my $self = shift; $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+HID} = gen_uid(); $UUID_VIA ||= Test2::API::_add_uuid_via_ref(); $self->{+UUID} = ${$UUID_VIA}->('hub') if $$UUID_VIA; $self->{+NESTED} = 0 unless defined $self->{+NESTED}; $self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED}; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; if (my $formatter = delete $self->{formatter}) { $self->format($formatter); } if (my $ipc = $self->{+IPC}) { $ipc->add_hub($self->{+HID}); } } sub is_subtest { 0 } sub _tb_reset { my $self = shift; # Nothing to do return if $self->{+PID} == $$ && $self->{+TID} == get_tid(); $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+HID} = gen_uid(); if (my $ipc = $self->{+IPC}) { $ipc->add_hub($self->{+HID}); } } sub reset_state { my $self = shift; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; delete $self->{+_PLAN}; delete $self->{+ENDED}; delete $self->{+BAILED_OUT}; delete $self->{+SKIP_REASON}; } sub inherit { my $self = shift; my ($from, %params) = @_; $self->{+NESTED} ||= 0; $self->{+_FORMATTER} = $from->{+_FORMATTER} unless $self->{+_FORMATTER} || exists($params{formatter}); if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } if (my $ls = $from->{+_LISTENERS}) { push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls; } if (my $pfs = $from->{+_PRE_FILTERS}) { push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs; } if (my $fs = $from->{+_FILTERS}) { push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs; } } sub format { my $self = shift; my $old = $self->{+_FORMATTER}; ($self->{+_FORMATTER}) = @_ if @_; return $old; } sub is_local { my $self = shift; return $$ == $self->{+PID} && get_tid() == $self->{+TID}; } sub listen { my $self = shift; my ($sub, %params) = @_; carp "Useless addition of a listener in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "listen only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_LISTENERS}} => { %params, code => $sub }; $sub; # Intentional return. } sub unlisten { my $self = shift; carp "Useless removal of a listener in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; my %subs = map {$_ => $_} @_; @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}}; } sub filter { my $self = shift; my ($sub, %params) = @_; carp "Useless addition of a filter in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "filter only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_FILTERS}} => { %params, code => $sub }; $sub; # Intentional Return } sub unfilter { my $self = shift; carp "Useless removal of a filter in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; my %subs = map {$_ => $_} @_; @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}}; } sub pre_filter { my $self = shift; my ($sub, %params) = @_; croak "pre_filter only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub }; $sub; # Intentional Return } sub pre_unfilter { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}}; } sub follow_up { my $self = shift; my ($sub) = @_; carp "Useless addition of a follow-up in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "follow_up only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_FOLLOW_UPS}} => $sub; } *add_context_aquire = \&add_context_acquire; sub add_context_acquire { my $self = shift; my ($sub) = @_; croak "add_context_acquire only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_ACQUIRE}} => $sub; $sub; # Intentional return. } *remove_context_aquire = \&remove_context_acquire; sub remove_context_acquire { my $self = shift; my %subs = map {$_ => 1} @_; @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} } @{$self->{+_CONTEXT_ACQUIRE}}; } sub add_context_init { my $self = shift; my ($sub) = @_; croak "add_context_init only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_INIT}} => $sub; $sub; # Intentional return. } sub remove_context_init { my $self = shift; my %subs = map {$_ => 1} @_; @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} } @{$self->{+_CONTEXT_INIT}}; } sub add_context_release { my $self = shift; my ($sub) = @_; croak "add_context_release only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_RELEASE}} => $sub; $sub; # Intentional return. } sub remove_context_release { my $self = shift; my %subs = map {$_ => 1} @_; @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} } @{$self->{+_CONTEXT_RELEASE}}; } sub send { my $self = shift; my ($e) = @_; $e->eid; $e->add_hub( { details => ref($self), buffered => $self->{+BUFFERED}, hid => $self->{+HID}, nested => $self->{+NESTED}, pid => $self->{+PID}, tid => $self->{+TID}, uuid => $self->{+UUID}, ipc => $self->{+IPC} ? 1 : 0, } ); $e->set_uuid(${$UUID_VIA}->('event')) if $$UUID_VIA; if ($self->{+_PRE_FILTERS}) { for (@{$self->{+_PRE_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } my $ipc = $self->{+IPC} || return $self->process($e); if($e->global) { $ipc->send($self->{+HID}, $e, 'GLOBAL'); return $self->process($e); } return $ipc->send($self->{+HID}, $e) if $$ != $self->{+PID} || get_tid() != $self->{+TID}; $self->process($e); } sub process { my $self = shift; my ($e) = @_; if ($self->{+_FILTERS}) { for (@{$self->{+_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } # Optimize the most common case my $type = ref($e); if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) { my $count = ++($self->{+COUNT}); $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; } return $e; } my $f = $e->facet_data; my $fail = 0; $fail = 1 if $f->{assert} && !$f->{assert}->{pass}; $fail = 1 if $f->{errors} && grep { $_->{fail} } @{$f->{errors}}; $fail = 0 if $f->{amnesty}; $self->{+COUNT}++ if $f->{assert}; $self->{+FAILED}++ if $fail && $f->{assert}; $self->{+_PASSING} = 0 if $fail; my $code = $f->{control} ? $f->{control}->{terminate} : undef; my $count = $self->{+COUNT}; if (my $plan = $f->{plan}) { if ($plan->{skip}) { $self->plan('SKIP'); $self->set_skip_reason($plan->{details} || 1); $code ||= 0; } elsif ($plan->{none}) { $self->plan('NO PLAN'); } else { $self->plan($plan->{count}); } } $e->callback($self) if $f->{control} && $f->{control}->{has_callback}; $self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { $_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}}; } if ($f->{control} && $f->{control}->{halt}) { $code ||= 255; $self->set_bailed_out($e); } if (defined $code) { $self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER}; $self->terminate($code, $e, $f); } return $e; } sub terminate { my $self = shift; my ($code) = @_; exit($code); } sub cull { my $self = shift; my $ipc = $self->{+IPC} || return; return if $self->{+PID} != $$ || $self->{+TID} != get_tid(); # No need to do IPC checks on culled events $self->process($_) for $ipc->cull($self->{+HID}); } sub finalize { my $self = shift; my ($trace, $do_plan) = @_; $self->cull(); my $plan = $self->{+_PLAN}; my $count = $self->{+COUNT}; my $failed = $self->{+FAILED}; my $active = $self->{+ACTIVE}; # return if NOTHING was done. unless ($active || $do_plan || defined($plan) || $count || $failed) { $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; return; } unless ($self->{+ENDED}) { if ($self->{+_FOLLOW_UPS}) { $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}}; } # These need to be refreshed now $plan = $self->{+_PLAN}; $count = $self->{+COUNT}; $failed = $self->{+FAILED}; if ((defined($plan) && $plan eq 'NO PLAN') || ($do_plan && !defined($plan))) { $self->send( Test2::Event::Plan->new( trace => $trace, max => $count, ) ); } $plan = $self->{+_PLAN}; } my $frame = $trace->frame; if($self->{+ENDED}) { my (undef, $ffile, $fline) = @{$self->{+ENDED}}; my (undef, $sfile, $sline) = @$frame; die <<" EOT" Test already ended! First End: $ffile line $fline Second End: $sfile line $sline EOT } $self->{+ENDED} = $frame; my $pass = $self->is_passing(); # Generate the final boolean. $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; return $pass; } sub is_passing { my $self = shift; ($self->{+_PASSING}) = @_ if @_; # If we already failed just return 0. my $pass = $self->{+_PASSING} or return 0; return $self->{+_PASSING} = 0 if $self->{+FAILED}; my $count = $self->{+COUNT}; my $ended = $self->{+ENDED}; my $plan = $self->{+_PLAN}; return $pass if !$count && $plan && $plan =~ m/^SKIP$/; return $self->{+_PASSING} = 0 if $ended && (!$count || !$plan); return $pass unless $plan && $plan =~ m/^\d+$/; if ($ended) { return $self->{+_PASSING} = 0 if $count != $plan; } else { return $self->{+_PASSING} = 0 if $count > $plan; } return $pass; } sub plan { my $self = shift; return $self->{+_PLAN} unless @_; my ($plan) = @_; confess "You cannot unset the plan" unless defined $plan; confess "You cannot change the plan" if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/; confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'" unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/; $self->{+_PLAN} = $plan; } sub check_plan { my $self = shift; return undef unless $self->{+ENDED}; my $plan = $self->{+_PLAN} || return undef; return 1 if $plan !~ m/^\d+$/; return 1 if $plan == $self->{+COUNT}; return 0; } sub DESTROY { my $self = shift; my $ipc = $self->{+IPC} || return; return unless $$ == $self->{+PID}; return unless get_tid() == $self->{+TID}; $ipc->drop_hub($self->{+HID}); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub - The conduit through which all events flow. =head1 SYNOPSIS use Test2::Hub; my $hub = Test2::Hub->new(); $hub->send(...); =head1 DESCRIPTION The hub is the place where all events get processed and handed off to the formatter. The hub also tracks test state, and provides several hooks into the event pipeline. =head1 COMMON TASKS =head2 SENDING EVENTS $hub->send($event) The C method is used to issue an event to the hub. This method will handle thread/fork sync, filters, listeners, TAP output, etc. =head2 ALTERING OR REMOVING EVENTS You can use either C or C, depending on your needs. Both have identical syntax, so only C is shown here. $hub->filter(sub { my ($hub, $event) = @_; my $action = get_action($event); # No action should be taken return $event if $action eq 'none'; # You want your filter to remove the event return undef if $action eq 'delete'; if ($action eq 'do_it') { my $new_event = copy_event($event); ... Change your copy of the event ... return $new_event; } die "Should not happen"; }); By default, filters are not inherited by child hubs. That means if you start a subtest, the subtest will not inherit the filter. You can change this behavior with the C parameter: $hub->filter(sub { ... }, inherit => 1); =head2 LISTENING FOR EVENTS $hub->listen(sub { my ($hub, $event, $number) = @_; ... do whatever you want with the event ... # return is ignored }); By default listeners are not inherited by child hubs. That means if you start a subtest, the subtest will not inherit the listener. You can change this behavior with the C parameter: $hub->listen(sub { ... }, inherit => 1); =head2 POST-TEST BEHAVIORS $hub->follow_up(sub { my ($trace, $hub) = @_; ... do whatever you need to ... # Return is ignored }); follow_up subs are called only once, either when done_testing is called, or in an END block. =head2 SETTING THE FORMATTER By default an instance of L is created and used. my $old = $hub->format(My::Formatter->new); Setting the formatter will REPLACE any existing formatter. You may set the formatter to undef to prevent output. The old formatter will be returned if one was already set. Only one formatter is allowed at a time. =head1 METHODS =over 4 =item $hub->send($event) This is where all events enter the hub for processing. =item $hub->process($event) This is called by send after it does any IPC handling. You can use this to bypass the IPC process, but in general you should avoid using this. =item $old = $hub->format($formatter) Replace the existing formatter instance with a new one. Formatters must be objects that implement a C<< $formatter->write($event) >> method. =item $sub = $hub->listen(sub { ... }, %optional_params) You can use this to record all events AFTER they have been sent to the formatter. No changes made here will be meaningful, except possibly to other listeners. $hub->listen(sub { my ($hub, $event, $number) = @_; ... do whatever you want with the event ... # return is ignored }); Normally listeners are not inherited by child hubs such as subtests. You can add the C<< inherit => 1 >> parameter to allow a listener to be inherited. =item $hub->unlisten($sub) You can use this to remove a listen callback. You must pass in the coderef returned by the C method. =item $sub = $hub->filter(sub { ... }, %optional_params) =item $sub = $hub->pre_filter(sub { ... }, %optional_params) These can be used to add filters. Filters can modify, replace, or remove events before anything else can see them. $hub->filter( sub { my ($hub, $event) = @_; return $event; # No Changes return; # Remove the event # Or you can modify an event before returning it. $event->modify; return $event; } ); If you are not using threads, forking, or IPC then the only difference between a C and a C is that C subs run first. When you are using threads, forking, or IPC, pre_filters happen to events before they are sent to their destination proc/thread, ordinary filters happen only in the destination hub/thread. You cannot add a regular filter to a hub if the hub was created in another process or thread. You can always add a pre_filter. =item $hub->unfilter($sub) =item $hub->pre_unfilter($sub) These can be used to remove filters and pre_filters. The C<$sub> argument is the reference returned by C or C. =item $hub->follow_op(sub { ... }) Use this to add behaviors that are called just before the hub is finalized. The only argument to your codeblock will be a L instance. $hub->follow_up(sub { my ($trace, $hub) = @_; ... do whatever you need to ... # Return is ignored }); follow_up subs are called only once, ether when done_testing is called, or in an END block. =item $sub = $hub->add_context_acquire(sub { ... }); Add a callback that will be called every time someone tries to acquire a context. It gets a single argument, a reference of the hash of parameters being used the construct the context. This is your chance to change the parameters by directly altering the hash. test2_add_callback_context_acquire(sub { my $params = shift; $params->{level}++; }); This is a very scary API function. Please do not use this unless you need to. This is here for L and backwards compatibility. This has you directly manipulate the hash instead of returning a new one for performance reasons. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_acquire($sub); This can be used to remove a context acquire hook. =item $sub = $hub->add_context_init(sub { ... }); This allows you to add callbacks that will trigger every time a new context is created for the hub. The only argument to the sub will be the L instance that was created. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_init($sub); This can be used to remove a context init hook. =item $sub = $hub->add_context_release(sub { ... }); This allows you to add callbacks that will trigger every time a context for this hub is released. The only argument to the sub will be the L instance that was released. These will run in reverse order. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_release($sub); This can be used to remove a context release hook. =item $hub->cull() Cull any IPC events (and process them). =item $pid = $hub->pid() Get the process id under which the hub was created. =item $tid = $hub->tid() Get the thread id under which the hub was created. =item $hud = $hub->hid() Get the identifier string of the hub. =item $uuid = $hub->uuid() If UUID tagging is enabled (see L) then the hub will have a UUID. =item $ipc = $hub->ipc() Get the IPC object used by the hub. =item $hub->set_no_ending($bool) =item $bool = $hub->no_ending This can be used to disable auto-ending behavior for a hub. The auto-ending behavior is triggered by an end block and is used to cull IPC events, and output the final plan if the plan was 'NO PLAN'. =item $bool = $hub->active =item $hub->set_active($bool) These are used to get/set the 'active' attribute. When true this attribute will force C<< hub->finalize() >> to take action even if there is no plan, and no tests have been run. This flag is useful for plugins that add follow-up behaviors that need to run even if no events are seen. =back =head2 STATE METHODS =over 4 =item $hub->reset_state() Reset all state to the start. This sets the test count to 0, clears the plan, removes the failures, etc. =item $num = $hub->count Get the number of tests that have been run. =item $num = $hub->failed Get the number of failures (Not all failures come from a test fail, so this number can be larger than the count). =item $bool = $hub->ended True if the testing has ended. This MAY return the stack frame of the tool that ended the test, but that is not guaranteed. =item $bool = $hub->is_passing =item $hub->is_passing($bool) Check if the overall test run is a failure. Can also be used to set the pass/fail status. =item $hub->plan($plan) =item $plan = $hub->plan Get or set the plan. The plan must be an integer larger than 0, the string 'NO PLAN', or the string 'SKIP'. =item $bool = $hub->check_plan Check if the plan and counts match, but only if the tests have ended. If tests have not ended this will return undef, otherwise it will be a true/false. =back =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at 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 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 Test000755001750001750 014772042322 16042 5ustar00exodistexodist000000000000Test-Simple-1.302210/libMore.pm100644001750001750 15221314772042322 17506 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Testpackage Test::More; use 5.006; use strict; use warnings; #---- perlcritic exemptions. ----# # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) # Can't use Carp because it might cause C to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my( $file, $line ) = ( caller(1) )[ 1, 2 ]; return warn @_, " at $file line $line\n"; } our $VERSION = '1.302210'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan done_testing can_ok isa_ok new_ok diag note explain subtest BAIL_OUT ); =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => 23; # or use Test::More skip_all => $reason; # or use Test::More; # see done_testing() require_ok( 'Some::Module' ); # Various ways to say "ok" ok($got eq $expected, $test_name); is ($got, $expected, $test_name); isnt($got, $expected, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($got, qr/expected/, $test_name); unlike($got, qr/expected/, $test_name); cmp_ok($got, '==', $expected, $test_name); is_deeply($got_complex_structure, $expected_complex_structure, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); BAIL_OUT($why); # UNIMPLEMENTED!!! my @status = Test::More::status; =head1 DESCRIPTION B If you're just getting started writing tests, have a look at L first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => 23; There are cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare your tests at the end. use Test::More; ... run your tests ... done_testing( $number_of_tests_run ); B C should never be called in an C block. Sometimes you really don't know how many tests were run, or it's too difficult to calculate. In which case you can leave off $number_of_tests_run. In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the C function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my $tb = Test::More->builder; return $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other; my $idx = 0; my $import; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } elsif( defined $item and $item eq 'import' ) { if ($import) { push @$import, @{$list->[ ++$idx ]}; } else { $import = $list->[ ++$idx ]; push @other, $item, $import; } } else { push @other, $item; } $idx++; } @$list = @other; if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { my $to = $class->builder->exported_to; no strict 'refs'; *{"$to\::TODO"} = \our $TODO; if ($import) { @$import = grep $_ ne '$TODO', @$import; } else { push @$list, import => [grep $_ ne '$TODO', @EXPORT]; } } return; } =over 4 =item B done_testing(); done_testing($number_of_tests); If you don't know how many tests you're going to run, you can issue the plan when you're done running tests. $number_of_tests is the same as C, it's the number of tests you expected to run. You can omit this, in which case the number of tests you ran doesn't matter, just the fact that your tests ran to conclusion. This is safer than and replaces the "no_plan" plan. B You must never put C inside an C block. The plan is there to ensure your test does not exit before testing has completed. If you use an END block you completely bypass this protection. =back =cut sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($got eq $expected, $test_name); This simply evaluates any expression (C<$got eq $expected> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep(!defined $_, @items), 'all items defined' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an C fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 'sufficient mucus' # in foo.t at line 42. This is the same as L's C routine. =cut sub ok ($;$) { my( $test, $name ) = @_; my $tb = Test::More->builder; return $tb->ok( $test, $name ); } =item B =item B is ( $got, $expected, $test_name ); isnt( $got, $expected, $test_name ); Similar to C, C and C compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); C will only ever match C. So you can test a value against C like this: is($not_defined, undef, "undefined as expected"); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. C cannot know what you are testing for (beyond the name), but C and C know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test 'Is foo the same as bar?' # in foo.t at line 139. # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use C and C over C where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); This does not check if C is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use C. ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); A simple call to C usually does not provide a strong test but there are cases when you cannot say much more about a value than that it is different from some other value: new_ok $obj, "Foo"; my $clone = $obj->clone; isa_ok $obj, "Foo", "Foo->clone"; isnt $obj, $clone, "clone() produces a different object"; Historically we supported an C function as an alias of C, however in Perl 5.37.9 support for the use of apostrophe as a package separator was deprecated and by Perl 5.42.0 support for it will have been removed completely. Accordingly use of C is also deprecated, and will produce warnings when used unless 'deprecated' warnings are specifically disabled in the scope where it is used. You are strongly advised to migrate to using C instead. =cut sub is ($$;$) { my $tb = Test::More->builder; return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; return $tb->isnt_eq(@_); } # Historically it was possible to use apostrophes as a package # separator. make this available as isn't() for perl's that support it. # However in 5.37.9 the apostrophe as a package separator was # deprecated, so warn users of isn't() that they should use isnt() # instead. We assume that if they are calling isn::t() they are doing so # via isn't() as we have no way to be sure that they aren't spelling it # with a double colon. We only trigger the warning if deprecation # warnings are enabled, so the user can silence the warning if they # wish. sub isn::t { local ($@, $!, $?); if (warnings::enabled("deprecated")) { _carp "Use of apostrophe as package separator was deprecated in Perl 5.37.9,\n", "and will be removed in Perl 5.42.0. You should change code that uses\n", "Test::More::isn't() to use Test::More::isnt() as a replacement"; } goto &isnt; } =item B like( $got, qr/expected/, $test_name ); Similar to C, C matches $got against the regex C. So this: like($got, qr/expected/, 'this is like that'); is similar to: ok( $got =~ m/expected/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $got, '/expected/', 'this is like that' ); Regex options may be placed on the end (C<'/expected/i'>). Its advantages over C are similar to that of C and C. Better diagnostics on failure. =cut sub like ($$;$) { my $tb = Test::More->builder; return $tb->like(@_); } =item B unlike( $got, qr/expected/, $test_name ); Works exactly as C, only it checks if $got B match the given pattern. =cut sub unlike ($$;$) { my $tb = Test::More->builder; return $tb->unlike(@_); } =item B cmp_ok( $got, $op, $expected, $test_name ); Halfway between C and C lies C. This allows you to compare two arguments using any binary perl operator. The test passes if the comparison is true and fails otherwise. # ok( $got eq $expected ); cmp_ok( $got, 'eq', $expected, 'this eq that' ); # ok( $got == $expected ); cmp_ok( $got, '==', $expected, 'this == that' ); # ok( $got && $expected ); cmp_ok( $got, '&&', $expected, 'this && that' ); ...etc... Its advantage over C is when the test fails you'll know what $got and $expected were: not ok 1 # Failed test in foo.t at line 12. # '23' # && # undef It's also useful in those cases where you are comparing numbers and C's use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); It's especially useful when comparing greater-than or smaller-than relation between values: cmp_ok( $some_value, '<=', $upper_limit ); =cut sub cmp_ok($$$;$) { my $tb = Test::More->builder; return $tb->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single C call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok; foreach my $method (@methods) { $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } my $name = (@methods == 1) ? "$class->can('$methods[0]')" : "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($subclass, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given C<< $object->isa($class) >>. Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. You can also test a class, to make sure that it has the right ancestor: isa_ok( 'Vole', 'Rodent' ); It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my( $thing, $class, $thing_name ) = @_; my $tb = Test::More->builder; my $whatami; if( !defined $thing ) { $whatami = 'undef'; } elsif( ref $thing ) { $whatami = 'reference'; local($@,$!); require Scalar::Util; if( Scalar::Util::blessed($thing) ) { $whatami = 'object'; } } else { $whatami = 'class'; } # We can't use UNIVERSAL::isa because we want to honor isa() overrides my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); if($error) { die <isa on your $whatami and got some weird error. Here's the error. $error WHOA } # Special case for isa_ok( [], "ARRAY" ) and like if( $whatami eq 'reference' ) { $rslt = UNIVERSAL::isa($thing, $class); } my($diag, $name); if( defined $thing_name ) { $name = "'$thing_name' isa '$class'"; $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; } elsif( $whatami eq 'object' ) { my $my_class = ref $thing; $thing_name = qq[An object of class '$my_class']; $name = "$thing_name isa '$class'"; $diag = "The object of class '$my_class' isn't a '$class'"; } elsif( $whatami eq 'reference' ) { my $type = ref $thing; $thing_name = qq[A reference of type '$type']; $name = "$thing_name isa '$class'"; $diag = "The reference of type '$type' isn't a '$class'"; } elsif( $whatami eq 'undef' ) { $thing_name = 'undef'; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't defined"; } elsif( $whatami eq 'class' ) { $thing_name = qq[The class (or class-like) '$thing']; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't a '$class'"; } else { die; } my $ok; if($rslt) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } return $ok; } =item B my $obj = new_ok( $class ); my $obj = new_ok( $class => \@args ); my $obj = new_ok( $class => \@args, $object_name ); A convenience function which combines creating an object and calling C on that object. It is basically equivalent to: my $obj = $class->new(@args); isa_ok $obj, $class, $object_name; If @args is not given, an empty list will be used. This function only works on C and it assumes C will return just a single object which isa C<$class>. =cut sub new_ok { my $tb = Test::More->builder; $tb->croak("new_ok() must be given at least a class") unless @_; my( $class, $args, $object_name ) = @_; $args ||= []; my $obj; my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); if($success) { local $Test::Builder::Level = $Test::Builder::Level + 1; isa_ok $obj, $class, $object_name; } else { $class = 'undef' if !defined $class; $tb->ok( 0, "$class->new() died" ); $tb->diag(" Error was: $error"); } return $obj; } =item B subtest $name => \&code, @args; C runs the &code as its own little test with its own plan and its own result. The main test counts this as a single test using the result of the whole subtest to determine if its ok or not ok. For example... use Test::More tests => 3; pass("First test"); subtest 'An example subtest' => sub { plan tests => 2; pass("This is a subtest"); pass("So is this"); }; pass("Third test"); This would produce. 1..3 ok 1 - First test # Subtest: An example subtest 1..2 ok 1 - This is a subtest ok 2 - So is this ok 2 - An example subtest ok 3 - Third test A subtest may call C. No tests will be run, but the subtest is considered a skip. subtest 'skippy' => sub { plan skip_all => 'cuz I said so'; pass('this test will never be run'); }; Returns true if the subtest passed, false otherwise. Due to how subtests work, you may omit a plan if you desire. This adds an implicit C to the end of your subtest. The following two subtests are equivalent: subtest 'subtest with implicit done_testing()', sub { ok 1, 'subtests with an implicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; }; subtest 'subtest with explicit done_testing()', sub { ok 1, 'subtests with an explicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; done_testing(); }; Extra arguments given to C are passed to the callback. For example: sub my_subtest { my $range = shift; ... } for my $range (1, 10, 100, 1000) { subtest "testing range $range", \&my_subtest, $range; } =cut sub subtest { my $tb = Test::More->builder; return $tb->subtest(@_); } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an C. In this case, you can simply use C (to declare the test ok) or fail (for not ok). They are synonyms for C and C. Use these very, very, very sparingly. =cut sub pass (;$) { my $tb = Test::More->builder; return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; return $tb->ok( 0, @_ ); } =back =head2 Module tests Sometimes you want to test if a module, or a list of modules, can successfully load. For example, you'll often want a first test which simply loads all the modules in the distribution to make sure they work before going on to do more complicated testing. For such purposes we have C and C. =over 4 =item B require_ok($module); require_ok($file); Tries to C the given $module or $file. If it loads successfully, the test will pass. Otherwise it fails and displays the load error. C will guess whether the input is a module name or a filename. No exception will be thrown if the load fails. # require Some::Module require_ok "Some::Module"; # require "Some/File.pl"; require_ok "Some/File.pl"; # stop testing if any of your modules will not load for my $module (@module) { require_ok $module or BAIL_OUT "Can't load $module"; } =cut sub require_ok ($) { my($module) = shift; my $tb = Test::More->builder; my $pack = caller; # Try to determine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); my $code = <ok( $eval_result, "require $module;" ); unless($ok) { chomp $eval_error; $tb->diag(< BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } Like C, but it will C the $module in question and only loads modules, not files. If you just want to test a module can be loaded, use C. If you just want to load a module in a test, we recommend simply using C directly. It will cause the test to stop. It's recommended that you run C inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); Version numbers can be checked like so: # Just like "use Some::Module 1.02" BEGIN { use_ok('Some::Module', 1.02) } Don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } because the notion of "compile-time" is relative. Instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } If you want the equivalent of C, use a module but not import anything, use C. BEGIN { require_ok "Foo" } =cut sub use_ok ($;@) { my( $module, @imports ) = @_; my $tb = Test::More->builder; my %caller; @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. $code = <ok( $eval_result, "use $module;" ); unless($ok) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(< I'm not quite sure what will happen with filehandles. =over 4 =item B is_deeply( $got, $expected, $test_name ); Similar to C, except that if $got and $expected are references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. C compares the dereferenced values of references, the references themselves (except for their type) are ignored. This means aspects such as blessing and ties are not considered "different". C currently has very limited handling of function reference and globs. It merely checks if they have the same referent. This may improve in the future. L and L provide more in-depth functionality along these lines. B is_deeply() has limitations when it comes to comparing strings and refs: my $path = path('.'); my $hash = {}; is_deeply( $path, "$path" ); # ok is_deeply( $hash, "$hash" ); # fail This happens because is_deeply will unoverload all arguments unconditionally. It is probably best not to use is_deeply with overloading. For legacy reasons this is not likely to ever be fixed. If you would like a much better tool for this you should see L Specifically L has an C function that works like C with many improvements. =cut our( @Data_Stack, %Refs_Seen ); my $DNE = bless [], 'Does::Not::Exist'; sub _dne { return ref $_[0] eq ref $DNE; } ## no critic (Subroutines::RequireArgUnpacking) sub is_deeply { my $tb = Test::More->builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <<'WARNING'; is_deeply() takes two or three args, you gave %d. This usually means you passed an array or hash instead of a reference to it WARNING chop $msg; # clip off newline so carp() will put in line/file _carp sprintf $msg, scalar @_; return $tb->ok(0); } my( $got, $expected, $name ) = @_; $tb->_unoverload_str( \$expected, \$got ); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq( $got, $expected, $name ); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check( $got, $expected ) ) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack(@Data_Stack) ); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars; ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } my %_types = ( (map +($_ => $_), qw( Regexp ARRAY HASH SCALAR REF GLOB CODE )), 'LVALUE' => 'SCALAR', 'REF' => 'SCALAR', 'VSTRING' => 'SCALAR', ); sub _type { my $thing = shift; return '' if !ref $thing; for my $type (keys %_types) { return $_types{$type} if UNIVERSAL::isa( $thing, $type ); } return ''; } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Like C @diagnostic_message is simply concatenated together. Returns false, so as to preserve failure. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test 'There's a foo user' # in foo.t at line 52. # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it won't interfere with the test. =item B note(@diagnostic_message); Like C, except the message will not be seen when the test is run in a harness. It will only be visible in the verbose TAP stream. Handy for putting in notes which might be useful for debugging, but don't indicate a problem. note("Tempfile is $tempfile"); =cut sub diag { return Test::More->builder->diag(@_); } sub note { return Test::More->builder->note(@_); } =item B my @dump = explain @diagnostic_message; Will dump the contents of any references in a human readable format. Usually you want to pass this into C or C. Handy for things like... is_deeply($have, $want) || diag explain $have; or note explain \%args; Some::Class->method(%args); =cut sub explain { return Test::More->builder->explain(@_); } =back =head2 Conditional tests Sometimes running a test under certain conditions will cause the test script to die. A certain function or method isn't implemented (such as C on MacOS), some resource isn't available (like a net connection) or a module isn't available. In these cases it's necessary to skip tests, or declare that they are supposed to fail but will work in the future (a todo test). For more details on the mechanics of skip and todo tests see L. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. If your plan is C $how_many is optional and will default to 1. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut ## no critic (Subroutines::RequireFinalReturn) sub skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; # If the plan is set, and is static, then skip needs a count. If the plan # is 'no_plan' we are fine. As well if plan is undefined then we are # waiting for done_testing. unless (defined $how_many) { my $plan = $tb->has_plan; _carp "skip() needs to know \$how_many tests are in the block" if $plan && $plan =~ m/^\d+$/; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1 .. $how_many ) { $tb->skip($why); } no warnings 'exiting'; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". L will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is that it is like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. Note that, if you leave $TODO unset or undef, Test::More reports failures as normal. This can be useful to mark the tests as expected to fail only in certain conditions, e.g.: TODO: { local $TODO = "$^O doesn't work yet. :(" if !_os_is_supported($^O); ... } =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. L will interpret them as passing. =cut sub todo_skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1 .. $how_many ) { $tb->todo_skip($why); } no warnings 'exiting'; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like C or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Test control =over 4 =item B BAIL_OUT($reason); Indicates to the harness that things are going so badly all testing should terminate. This includes the running of any additional test scripts. This is typically used when testing cannot continue such as a critical module failing to compile or a necessary external utility not being available such as a database connection failing. The test will exit with 255. For even better control look at L. =cut sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } =back =head2 Discouraged comparison functions The use of the following functions is discouraged as they are not actually testing functions and produce no diagnostics to help figure out what went wrong. They were written before C existed because I couldn't figure out how to display a useful diff of two arbitrary data structures. These functions are usually used inside an C. ok( eq_array(\@got, \@expected) ); C can do that better and with diagnostics. is_deeply( \@got, \@expected ); They may be deprecated in future versions. =over 4 =item B my $is_eq = eq_array(\@got, \@expected); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { local @Data_Stack = (); _deep_check(@_); } sub _eq_array { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _equal_nonrefs { my( $e1, $e2 ) = @_; return if ref $e1 or ref $e2; if ( defined $e1 ) { return 1 if defined $e2 and $e1 eq $e2; } else { return 1 if !defined $e2; } return; } sub _deep_check { my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. my $same_ref = !( !ref $e1 xor !ref $e2 ); my $not_ref = ( !ref $e1 and !ref $e2 ); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif( !defined $e1 and !defined $e2 ) { # Shortcut if they're both undefined. $ok = 1; } elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } elsif($not_ref) { push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif($type) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } else { _whoa( 1, "No type in _deep_check" ); } } } return $ok; } sub _whoa { my( $check, $desc ) = @_; if($check) { die <<"WHOA"; WHOA! $desc This should never happen! Please contact the author immediately! WHOA } } =item B my $is_eq = eq_hash(\%got, \%expected); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B my $is_eq = eq_set(\@got, \@expected); Similar to C, except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. ok( eq_set(\@got, \@expected) ); Is better written: is_deeply( [sort @got], [sort @expected] ); B By historical accident, this is not a true set comparison. While the order of elements does not matter, duplicate elements do. B C does not know how to deal with references at the top level. The following is an example of a comparison which might not work: eq_set([\1, \2], [\2, \1]); L contains much better set comparison functions. =cut sub eq_set { my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; no warnings 'uninitialized'; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of L which provides a single, unified backend for any test library to use. This means two test libraries which both use L B be used together in the same program. If you simply want to do a little tweaking of how the tests behave, you can access the underlying L object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the L object underlying Test::More for you to play with. =back =head1 EXIT CODES If all your tests passed, L will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run L will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. B This behavior may go away in future versions. =head1 COMPATIBILITY Test::More works with Perls as old as 5.8.1. Thread support is not very reliable before 5.10.1, but that's because threads are not very reliable before 5.10.1. Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. Key feature milestones include: =over 4 =item subtests Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. =item C This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C Although C was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C C and C These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =back There is a full version history in the Changes file, and the Test::More versions included as core can be found using L: $ corelist -a Test::More =head1 CAVEATS and NOTES =over 4 =item UTF-8 / "Wide character in print" If you use UTF-8 or other non-ASCII characters with Test::More you might get a "Wide character in print" warning. Using C<< binmode STDOUT, ":utf8" >> will not fix it. L (which powers Test::More) duplicates STDOUT and STDERR. So any changes to them, including changing their output disciplines, will not be seen by Test::More. One work around is to apply encodings to STDOUT and STDERR as early as possible and before Test::More (or any other Test module) loads. use open ':std', ':encoding(UTF-8)'; use Test::More; A more direct work around is to change the filehandles used by L. my $builder = Test::More->builder; binmode $builder->output, ":encoding(UTF-8)"; binmode $builder->failure_output, ":encoding(UTF-8)"; binmode $builder->todo_output, ":encoding(UTF-8)"; =item Overloaded objects String overloaded objects are compared B (or in C's case, strings or numbers as appropriate to the comparison op). This prevents Test::More from piercing an object's interface allowing better blackbox testing. So if a function starts returning overloaded objects instead of bare strings your tests won't notice the difference. This is good. However, it does mean that functions like C cannot be used to test the internals of string overloaded objects. In this case I would suggest L which contains more flexible testing functions for complex data structures. =item Threads Test::More will only be aware of threads if C has been done I Test::More is loaded. This is ok: use threads; use Test::More; This may cause problems: use Test::More use threads; 5.8.1 and above are supported. Anything below that has too many bugs. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's L module. I was largely unaware of its existence when I'd first written my own C routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO =head2 =head2 ALTERNATIVES L is the most recent and modern set of tools for testing. L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L tests written with Test.pm, the original testing module, do not play well with other testing libraries. Test::Legacy emulates the Test.pm interface and does play well with others. =head2 ADDITIONAL LIBRARIES L for more ways to test complex data structures. And it plays well with Test::More. L is like xUnit but more perlish. L gives you more powerful complex data structure testing. L shows the idea of embedded testing. L The ultimate mocking library. Easily spawn objects defined on the fly. Can also override, block, or reimplement packages as needed. L Quickly define fixture data for unit tests. =head2 OTHER COMPONENTS L is the test runner and output interpreter for Perl. It's the thing that powers C and where the C utility comes from. =head2 BUNDLES L Most commonly needed test functions and features. =head1 ENVIRONMENT VARIABLES See L for a list of meaningul environment variables. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa gang. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 BUGS See L to report and view bugs. =head1 SOURCE The source code repository for Test::More can be found at L. =head1 COPYRIGHT Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut 1; Todo.t100644001750001750 352514772042322 17527 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse 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; Mock.t100644001750001750 7003614772042322 17534 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse 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 overridden") 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"); }; subtest prototypes => sub { sub foo_022 ($) { $_[0] } # Because this is test 22. # NOTE that we make use of the prototype in the following code. is(foo_022 'bar', 'bar', 'foo_022 returns its argument'); my $one = Test2::Mock->new(class => __PACKAGE__); my $warning = warnings { $one->before(foo_022 => sub ($) { warn "Before foo_022( '$_[0]' )" }); is(foo_022 'baz', 'baz', 'foo_022 still returns its argument'); }; is( $warning, [ match qr/\ABefore foo_022\( 'baz' \)/, ], 'Got warning from before() hook' ); $one->reset_all(); $warning = warnings { is(foo_022 'foo', 'foo', 'foo_022 persists in returning its argument'); }; is $warning, [], 'No warnings after resetting mock'; $warning = warnings { $one->after(foo_022 => sub ($) { warn "After foo_022( '$_[0]' )" }); is(foo_022 'plugh', 'plugh', 'foo_022 steadfastly returns its argument'); }; is( $warning, [ match qr/\AAfter foo_022\( 'plugh' \)/, ], 'Got warning from after() hook' ); $one->reset_all(); $warning = warnings { $one->around(foo_022 => sub ($) { return $_[0]->($_[1]) x 2 }); is foo_022 '42', '4242', 'With around(), foo_022 now doubles its return'; }; is($warning, [], 'around() produced no warnings'); }; done_testing; extra.t100644001750001750 216214772042322 17475 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } else { unshift @INC, 't/lib'; } } use strict; use Test::Builder; use Test::Builder::NoOutput; use Test::Simple; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; my $TB = Test::Builder->new; my $test = Test::Builder::NoOutput->create; $test->$plan( tests => 3 ); local $ENV{HARNESS_ACTIVE} = 0; $test->$ok(1, 'Foo'); $TB->is_eq($test->read(), <$ok(0, 'Bar'); $TB->is_eq($test->read(), <$ok(1, 'Yar'); $test->$ok(1, 'Car'); $TB->is_eq($test->read(), <$ok(0, 'Sar'); $TB->is_eq($test->read(), <_ending(); $TB->is_eq($test->read(), <$done_testing(5); depth.t100644001750001750 57714772042322 17446 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use warnings; use lib 't/lib'; use Test::Tester; use MyTest; my $test = Test::Builder->new; $test->plan(tests => 2); sub deeper { MyTest::ok(1); } { my @results = run_tests( sub { MyTest::ok(1); deeper(); } ); local $Test::Builder::Level = 0; $test->is_num($results[1]->{depth}, 1, "depth 1"); $test->is_num($results[2]->{depth}, 2, "deeper"); } undef.t100644001750001750 372114772042322 17455 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # HARNESS-NO-FORK BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 21; BEGIN { $^W = 1; } my $warnings = ''; local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; my $TB = Test::Builder->new; sub no_warnings { $TB->is_eq($warnings, '', ' no warnings'); $warnings = ''; } sub warnings_is { $TB->is_eq($warnings, $_[0]); $warnings = ''; } sub warnings_like { $TB->like($warnings, $_[0]); $warnings = ''; } my $Filename = quotemeta $0; is( undef, undef, 'undef is undef'); no_warnings; isnt( undef, 'foo', 'undef isnt foo'); no_warnings; isnt( undef, '', 'undef isnt an empty string' ); isnt( undef, 0, 'undef isnt zero' ); Test::More->builder->is_num(undef, undef, 'is_num()'); Test::More->builder->isnt_num(23, undef, 'isnt_num()'); #line 45 like( undef, qr/.*/, 'undef is like anything' ); no_warnings; eq_array( [undef, undef], [undef, 23] ); no_warnings; eq_hash ( { foo => undef, bar => undef }, { foo => undef, bar => 23 } ); no_warnings; eq_set ( [undef, undef, 12], [29, undef, undef] ); no_warnings; eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } }, { foo => undef, bar => { baz => undef, moo => 23 } } ); no_warnings; #line 74 cmp_ok( undef, '<=', 2, ' undef <= 2' ); warnings_like(qr/Use of uninitialized value.* at \(eval in cmp_ok\) $Filename line 74\.\n/); my $tb = Test::More->builder; SKIP: { skip("Test cannot be run with this formatter", 2) unless $tb->{Stack}->top->format->isa('Test::Builder::Formatter'); my $err = ''; $tb->failure_output(\$err); diag(undef); $tb->reset_outputs; is( $err, "# undef\n" ); no_warnings; } $tb->maybe_regex(undef); no_warnings; # test-more.googlecode.com #42 { is_deeply([ undef ], [ undef ]); no_warnings; } SkipAll.pm100644001750001750 10714772042322 17401 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libpackage SkipAll; use strict; use warnings; main::skip_all("foo"); 1; tools.pl100644001750001750 577514772042322 20046 0ustar00exodistexodist000000000000Test-Simple-1.302210/examplespackage Test2::Example; use Scalar::Util qw/blessed/; use Test2::Util qw/try/; use Test2 qw/context run_subtest/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); sub ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool ? 1 : 0; } sub is($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" eq "$want"; } elsif (defined($got) xor defined($want)) { $bool = 0; } else { # Both are undef $bool = 1; } unless ($bool) { $got = '*NOT DEFINED*' unless defined $got; $want = '*NOT DEFINED*' unless defined $want; unshift @diag => ( "GOT: $got", "EXPECTED: $want", ); } $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub isnt($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" ne "$want"; } elsif (defined($got) xor defined($want)) { $bool = 1; } else { # Both are undef $bool = 0; } unshift @diag => "Strings are the same (they should not be)" unless $bool; $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub like($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" =~ $pattern; unshift @diag => ( "Value: $thing", "Does not match: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub unlike($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" !~ $pattern; unshift @diag => ( "Unexpected pattern match (it should not match)", "Value: $thing", "Matches: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub diag { my $ctx = context(); $ctx->diag( join '', @_ ); $ctx->release; } sub note { my $ctx = context(); $ctx->note( join '', @_ ); $ctx->release; } sub skip_all { my ($reason) = @_; my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release if $ctx; } sub plan { my ($max) = @_; my $ctx = context(); $ctx->plan($max); $ctx->release; } sub done_testing { my $ctx = context(); $ctx->done_testing; $ctx->release; } sub subtest { my ($name, $code) = @_; my $ctx = context(); my $bool = run_subtest($name, $code, 1); $ctx->release; return $bool; } 1; Util.pm100644001750001750 2237614772042322 17571 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Util; use strict; use warnings; our $VERSION = '1.302210'; use Config qw/%Config/; use Carp qw/croak/; BEGIN { *HAVE_PERLIO = defined &PerlIO::get_layers ? sub() { 1 } : sub() { 0 }; } our @EXPORT_OK = qw{ try pkg_to_file get_tid USE_THREADS CAN_THREAD CAN_REALLY_FORK CAN_FORK CAN_SIGSYS IS_WIN32 ipc_separator gen_uid do_rename do_unlink try_sig_mask clone_io }; BEGIN { require Exporter; our @ISA = qw(Exporter) } BEGIN { *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; } sub _can_thread { return 0 unless $] >= 5.008001; return 0 unless $Config{'useithreads'}; # Threads are broken on perl 5.10.0 built with gcc 4.8+ if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { return 0 unless $Config{'gccversion'} =~ m/^(\d+)\.(\d+)/; my @parts = split /[\.\s]+/, $Config{'gccversion'}; return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); } # Change to a version check if this ever changes return 0 if $INC{'Devel/Cover.pm'}; return 1; } sub _can_fork { return 1 if $Config{d_fork}; return 0 unless IS_WIN32 || $^O eq 'NetWare'; return 0 unless $Config{useithreads}; return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; return _can_thread(); } BEGIN { no warnings 'once'; *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; } my $can_fork; sub CAN_FORK () { return $can_fork if defined $can_fork; $can_fork = !!_can_fork(); no warnings 'redefine'; *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; $can_fork; } my $can_really_fork; sub CAN_REALLY_FORK () { return $can_really_fork if defined $can_really_fork; $can_really_fork = !!$Config{d_fork}; no warnings 'redefine'; *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; $can_really_fork; } sub _manual_try(&;@) { my $code = shift; my $args = \@_; my $err; my $die = delete $SIG{__DIE__}; eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__}; return (!defined($err), $err); } sub _local_try(&;@) { my $code = shift; my $args = \@_; my $err; no warnings; local $SIG{__DIE__}; eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; return (!defined($err), $err); } # Older versions of perl have a nasty bug on win32 when localizing a variable # before forking or starting a new thread. So for those systems we use the # non-local form. When possible though we use the faster 'local' form. BEGIN { if (IS_WIN32 && $] < 5.020002) { *try = \&_manual_try; } else { *try = \&_local_try; } } BEGIN { if (CAN_THREAD) { if ($INC{'threads.pm'}) { # Threads are already loaded, so we do not need to check if they # are loaded each time *USE_THREADS = sub() { 1 }; *get_tid = sub() { threads->tid() }; } else { # :-( Need to check each time to see if they have been loaded. *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 }; *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 }; } } else { # No threads, not now, not ever! *USE_THREADS = sub() { 0 }; *get_tid = sub() { 0 }; } } sub pkg_to_file { my $pkg = shift; my $file = $pkg; $file =~ s{(::|')}{/}g; $file .= '.pm'; return $file; } sub ipc_separator() { "~" } my $UID = 1; sub gen_uid() { join ipc_separator() => ($$, get_tid(), time, $UID++) } sub _check_for_sig_sys { my $sig_list = shift; return $sig_list =~ m/\bSYS\b/; } my $CAN_SIGSYS; sub CAN_SIGSYS () { if (!defined $CAN_SIGSYS) { $CAN_SIGSYS = _check_for_sig_sys($Config{sig_name}); } $CAN_SIGSYS; } my %PERLIO_SKIP = ( unix => 1, via => 1, ); sub clone_io { my ($fh) = @_; my $fileno = eval { fileno($fh) }; return $fh if !defined($fileno) || !length($fileno) || $fileno < 0; open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!"; my %seen; my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : (); binmode($out, join(":", "", "raw", @layers)); my $old = select $fh; my $af = $|; select $out; $| = $af; select $old; return $out; } BEGIN { if (IS_WIN32) { my $max_tries = 5; *do_rename = sub { my ($from, $to) = @_; my $err; for (1 .. $max_tries) { return (1) if rename($from, $to); $err = "$!"; last if $_ == $max_tries; sleep 1; } return (0, $err); }; *do_unlink = sub { my ($file) = @_; my $err; for (1 .. $max_tries) { return (1) if unlink($file); $err = "$!"; last if $_ == $max_tries; sleep 1; } return (0, "$!"); }; } else { *do_rename = sub { my ($from, $to) = @_; return (1) if rename($from, $to); return (0, "$!"); }; *do_unlink = sub { my ($file) = @_; return (1) if unlink($file); return (0, "$!"); }; } } #for backwards compatibility sub try_sig_mask(&) { require Test2::Util::Sig; goto &Test2::Util::Sig::try_sig_mask; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util - Tools used by Test2 and friends. =head1 DESCRIPTION Collection of tools used by L and friends. =head1 EXPORTS All exports are optional. You must specify subs to import. =over 4 =item ($success, $error) = try { ... } Eval the codeblock, return success or failure, and the error message. This code protects $@ and $!, they will be restored by the end of the run. This code also temporarily blocks $SIG{DIE} handlers. =item protect { ... } Similar to try, except that it does not catch exceptions. The idea here is to protect $@ and $! from changes. $@ and $! will be restored to whatever they were before the run so long as it is successful. If the run fails $! will still be restored, but $@ will contain the exception being thrown. =item CAN_FORK True if this system is capable of true or pseudo-fork. =item CAN_REALLY_FORK True if the system can really fork. This will be false for systems where fork is emulated. =item CAN_THREAD True if this system is capable of using threads. =item USE_THREADS Returns true if threads are enabled, false if they are not. =item get_tid This will return the id of the current thread when threads are enabled, otherwise it returns 0. =item my $file = pkg_to_file($package) Convert a package name to a filename. =item $string = ipc_separator() Get the IPC separator. Currently this is always the string C<'~'>. =item $string = gen_uid() Generate a unique id (NOT A UUID). This will typically be the process id, the thread id, the time, and an incrementing integer all joined with the C. These ID's are unique enough for most purposes. For identical ids to be generated you must have 2 processes with the same PID generate IDs at the same time with the same current state of the incrementing integer. This is a perfectly reasonable thing to expect to happen across multiple machines, but is quite unlikely to happen on one machine. This can fail to be unique if a process generates an id, calls exec, and does it again after the exec and it all happens in less than a second. It can also happen if the systems process id's cycle in less than a second allowing 2 different programs that use this generator to run with the same PID in less than a second. Both these cases are sufficiently unlikely. If you need universally unique ids, or ids that are unique in these conditions, look at L. =item ($ok, $err) = do_rename($old_name, $new_name) Rename a file, this wraps C in a way that makes it more reliable cross-platform when trying to rename files you recently altered. =item ($ok, $err) = do_unlink($filename) Unlink a file, this wraps C in a way that makes it more reliable cross-platform when trying to unlink files you recently altered. =back =head1 NOTES && CAVEATS =over 4 =item 5.10.0 Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a segfault whenever a new thread is launched. Test2 will attempt to detect this, and note that the system is not capable of forking when it is detected. =item Devel::Cover Devel::Cover does not support threads. CAN_THREAD will return false if Devel::Cover is loaded before the check is first run. =back =head1 SOURCE The source code repository for Test2 can be found at L. =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 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 Mock.pm100644001750001750 5441714772042322 17546 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Mock; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/croak confess/; our @CARP_NOT = (__PACKAGE__); use Scalar::Util qw/weaken reftype blessed set_prototype/; 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, required => 1); $self->_inject({}, $name => set_prototype(sub { $sub->(@_); $orig->(@_) }, prototype $sub)); } sub after { my $self = shift; my ($name, $sub) = @_; $self->_check(); my $orig = $self->current($name, required => 1); $self->_inject( {}, $name => set_prototype( 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; }, prototype $sub, ) ); } sub around { my $self = shift; my ($name, $sub) = @_; $self->_check(); my $orig = $self->current($name, required => 1); $self->_inject({}, $name => set_prototype(sub { $sub->($orig, @_) }, prototype $sub)); } 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, %params) = @_; my $out = get_symbol($sym, $self->{+CLASS}); return $out unless $params{required}; confess "Attempt to modify a sub that does not exist '$self->{+CLASS}\::$sym' (Mock operates on packages, not classes, are you looking for a symbol in a parent class?)" unless $out; return $out; } 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 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 Todo.pm100644001750001750 741414772042322 17535 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package 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 = '1.302210'; 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 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 Tools.t100644001750001750 13514772042322 17674 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse Test2::Bundle::Extended; use Test2::Tools; pass("Loaded Test2::Tools"); done_testing; Suite.t100644001750001750 21414772042322 17663 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse Test2::Bundle::Extended; use Test2::Suite; pass("Loaded Test2::Suite"); ok($Test2::Suite::VERSION, "have a version"); done_testing; acceptance000755001750001750 014772042322 16706 5ustar00exodistexodist000000000000Test-Simple-1.302210/tOO.t100644001750001750 517614772042322 17561 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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; simple.t100644001750001750 31014772042322 17614 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/LegacyBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; BEGIN { $| = 1; $^W = 1; } use Test::Simple tests => 3; ok(1, 'compile'); ok(1); ok(1, 'foo'); useing.t100644001750001750 55514772042322 17630 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/LegacyBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 5; require_ok('Test::Builder'); require_ok("Test::More"); require_ok("Test::Simple"); { package Foo; use Test::More import => [qw(ok is can_ok)]; can_ok('Foo', qw(ok is can_ok)); ok( !Foo->can('like'), 'import working properly' ); } import.t100644001750001750 36414772042322 17646 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/LegacyBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 2, import => [qw(!fail)]; can_ok(__PACKAGE__, qw(ok pass like isa_ok)); ok( !__PACKAGE__->can('fail'), 'fail() not exported' ); c_flag.t100644001750001750 71214772042322 17544 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD # Test::More should not print anything when Perl is only doing # a compile as with the -c flag or B::Deparse or perlcc. # HARNESS_ACTIVE=1 was causing an error with -c { local $ENV{HARNESS_ACTIVE} = 1; local $^C = 1; require Test::More; Test::More->import(tests => 1); fail("This should not show up"); } Test::More->builder->no_ending(1); print "1..1\n"; print "ok 1\n"; use_ok.t100644001750001750 445114772042322 17642 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Test::More; note "Basic use_ok"; { package Foo::one; ::use_ok("Symbol"); ::ok( defined &gensym, 'use_ok() no args exports defaults' ); } note "With one arg"; { package Foo::two; ::use_ok("Symbol", qw(qualify)); ::ok( !defined &gensym, ' one arg, defaults overridden' ); ::ok( defined &qualify, ' right function exported' ); } note "Multiple args"; { package Foo::three; ::use_ok("Symbol", qw(gensym ungensym)); ::ok( defined &gensym && defined &ungensym, ' multiple args' ); } note "Defining constants"; { package Foo::four; my $warn; local $SIG{__WARN__} = sub { $warn .= shift; }; ::use_ok("constant", qw(foo bar)); ::ok( defined &foo, 'constant' ); ::is( $warn, undef, 'no warning'); } note "use Module VERSION"; { package Foo::five; ::use_ok("Symbol", 1.02); } note "use Module VERSION does not call import"; { package Foo::six; ::use_ok("NoExporter", 1.02); } { package Foo::seven; local $SIG{__WARN__} = sub { # Old perls will warn on X.YY_ZZ style versions. Not our problem warn @_ unless $_[0] =~ /^Argument "\d+\.\d+_\d+" isn't numeric/; }; ::use_ok("Test::More", 0.47); } note "Signals are preserved"; { package Foo::eight; local $SIG{__DIE__}; ::use_ok("SigDie"); ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved'); } note "Line numbers preserved"; { my $package = "that_cares_about_line_numbers"; # Store the output of caller. my @caller; { package that_cares_about_line_numbers; sub import { @caller = caller; return; } $INC{"$package.pm"} = 1; # fool use into thinking it's already loaded } ::use_ok($package); my $line = __LINE__-1; ::is( $caller[0], __PACKAGE__, "caller package preserved" ); ::is( $caller[1], __FILE__, " file" ); ::is( $caller[2], $line, " line" ); } note "not confused by functions vs class names"; { $INC{"ok.pm"} = 1; use_ok("ok"); # ok is a function inside Test::More $INC{"Foo/bar.pm"} = 1; sub Foo::bar { 42 } use_ok("Foo::bar"); # Confusing a class name with a function name } done_testing; new_ok.t100644001750001750 130114772042322 17626 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w use strict; use Test::More tests => 13; { package Bar; sub new { my $class = shift; return bless {@_}, $class; } package Foo; our @ISA = qw(Bar); } { my $obj = new_ok("Foo"); is_deeply $obj, {}; isa_ok $obj, "Foo"; $obj = new_ok("Bar"); is_deeply $obj, {}; isa_ok $obj, "Bar"; $obj = new_ok("Foo", [this => 42]); is_deeply $obj, { this => 42 }; isa_ok $obj, "Foo"; $obj = new_ok("Foo", [], "Foo"); is_deeply $obj, {}; isa_ok $obj, "Foo"; } # And what if we give it nothing? eval { new_ok(); }; is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2; cmp_ok.t100755001750001750 354314772042322 17631 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; require Test::Builder; my $TB = Test::Builder->create; $TB->level(0); sub try_cmp_ok { my($left, $cmp, $right, $error) = @_; my %expect; if( $error ) { $expect{ok} = 0; $expect{error} = $error; } else { $expect{ok} = eval "\$left $cmp \$right"; $expect{error} = $@; $expect{error} =~ s/ at .*\n?//; } local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok; eval { $ok = cmp_ok($left, $cmp, $right, "cmp_ok"); }; $TB->is_num(!!$ok, !!$expect{ok}, " right return"); my $diag = $err->read; if ($@) { $diag = $@; $diag =~ s/ at .*\n?//; } if( !$ok and $expect{error} ) { $diag =~ s/^# //mg; $TB->like( $diag, qr/\Q$expect{error}\E/, " expected error" ); } elsif( $ok ) { $TB->is_eq( $diag, '', " passed without diagnostic" ); } else { $TB->ok(1, " failed without diagnostic"); } } use Test::More; Test::More->builder->no_ending(1); require MyOverload; my $cmp = Overloaded::Compare->new("foo", 42); my $ify = Overloaded::Ify->new("bar", 23); my $part = Overloaded::Partial->new('baz', 0); my @Tests = ( [1, '==', 1], [1, '==', 2], ["a", "eq", "b"], ["a", "eq", "a"], [1, "+", 1], [1, "-", 1], [$cmp, '==', 42], [$cmp, 'eq', "foo"], [$ify, 'eq', "bar"], [$ify, "==", 23], [$part, '!=', 0, 'expected: anything else'], [1, "=", 0, "= is not a valid comparison operator in cmp_ok()"], [1, "+=", 0, "+= is not a valid comparison operator in cmp_ok()"], ); plan tests => scalar @Tests; $TB->plan(tests => @Tests * 2); for my $test (@Tests) { try_cmp_ok(@$test); } eq_set.t100644001750001750 106214772042322 17630 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use strict; use Test::More; plan tests => 4; # RT 3747 ok( eq_set([1, 2, [3]], [[3], 1, 2]) ); ok( eq_set([1,2,[3]], [1,[3],2]) ); # bugs.perl.org 36354 my $ref = \2; ok( eq_set( [$ref, "$ref", "$ref", $ref], ["$ref", $ref, $ref, "$ref"] ) ); TODO: { local $TODO = q[eq_set() doesn't really handle references]; ok( eq_set( [\1, \2, \3], [\2, \3, \1] ) ); } buffer.t100644001750001750 73214772042322 17604 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl # HARNESS-NO-STREAM use strict; use warnings; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } # Ensure that intermixed prints to STDOUT and tests come out in the # right order (ie. no buffering problems). use Test::More tests => 20; my $T = Test::Builder->new; $T->no_ending(1); for my $num (1..10) { my $tnum = $num * 2; pass("I'm ok"); $T->current_test($tnum); print "ok $tnum - You're ok\n"; } strays.t100644001750001750 74014772042322 17657 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # Check that stray newlines in test output are properly handed. BEGIN { print "1..0 # Skip not completed\n"; exit 0; } BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->create; $tb->ok(1, "name\n"); $tb->ok(0, "foo\nbar\nbaz"); $tb->skip("\nmoofer"); $tb->todo_skip("foo\n\n"); Dev000755001750001750 014772042322 16104 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/libNull.pm100644001750001750 12714772042322 17474 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Devpackage Dev::Null; use strict; sub TIEHANDLE { bless {}, shift } sub PRINT { 1 } 1; subtest.t100644001750001750 53414772042322 20173 0ustar00exodistexodist000000000000Test-Simple-1.302210/examples#!/usr/bin/env perl use strict; use warnings; use lib '../lib'; use Test::More tests => 3; ok 1; subtest 'some name' => sub { my $num_tests = 2 + int( rand(3) ); plan tests => $num_tests; ok 1 for 1 .. $num_tests - 1; subtest 'some name' => sub { plan 'no_plan'; ok 1 for 1 .. 2 + int( rand(3) ); }; }; ok 1; indent.pl100644001750001750 125114772042322 20150 0ustar00exodistexodist000000000000Test-Simple-1.302210/examples#!/usr/bin/env perl use strict; use warnings; use lib '../lib'; use Test::Builder; =head1 NOTES Must have explicit finalize Must name nest Trailing summary test Pass chunk o'TAP No builder may have more than one child active What happens if you call ->finalize with open children =cut my $builder = Test::Builder->new; $builder->plan(tests => 7); for( 1 .. 3 ) { $builder->ok( $_, "We're on $_" ); $builder->note("We ran $_"); } { my $indented = $builder->child; $indented->plan('no_plan'); for( 1 .. 1+int(rand(5)) ) { $indented->ok( 1, "We're on $_" ); } $indented->finalize; } for( 7, 8, 9 ) { $builder->ok( $_, "We're on $_" ); } Suite.pm100644001750001750 2237714772042322 17746 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Suite; use strict; use warnings; our $VERSION = '1.302210'; 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 affects 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 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 Tools.pm100644001750001750 500214772042322 17717 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Tools; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Event.pm100644001750001750 5415414772042322 17734 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Event; use strict; use warnings; our $VERSION = '1.302210'; use Scalar::Util qw/blessed reftype/; use Carp qw/croak/; use Test2::Util::HashBase qw/trace -amnesty uuid -_eid -hubs/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util qw/pkg_to_file gen_uid/; use Test2::EventFacet::About(); use Test2::EventFacet::Amnesty(); use Test2::EventFacet::Assert(); use Test2::EventFacet::Control(); use Test2::EventFacet::Error(); use Test2::EventFacet::Info(); use Test2::EventFacet::Meta(); use Test2::EventFacet::Parent(); use Test2::EventFacet::Plan(); use Test2::EventFacet::Trace(); use Test2::EventFacet::Hub(); # Legacy tools will expect this to be loaded now require Test2::Util::Trace; my %LOADED_FACETS = ( 'about' => 'Test2::EventFacet::About', 'amnesty' => 'Test2::EventFacet::Amnesty', 'assert' => 'Test2::EventFacet::Assert', 'control' => 'Test2::EventFacet::Control', 'errors' => 'Test2::EventFacet::Error', 'info' => 'Test2::EventFacet::Info', 'meta' => 'Test2::EventFacet::Meta', 'parent' => 'Test2::EventFacet::Parent', 'plan' => 'Test2::EventFacet::Plan', 'trace' => 'Test2::EventFacet::Trace', 'hubs' => 'Test2::EventFacet::Hub', ); sub FACET_TYPES { sort values %LOADED_FACETS } sub load_facet { my $class = shift; my ($facet) = @_; return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet}; my @check = ($facet); if ('s' eq substr($facet, -1, 1)) { push @check => substr($facet, 0, -1); } else { push @check => $facet . 's'; } my $found; for my $check (@check) { my $mod = "Test2::EventFacet::" . ucfirst($facet); my $file = pkg_to_file($mod); next unless eval { require $file; 1 }; $found = $mod; last; } return undef unless $found; $LOADED_FACETS{$facet} = $found; } sub causes_fail { 0 } sub increments_count { 0 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub callback { } sub terminate { () } sub global { () } sub sets_plan { () } sub summary { ref($_[0]) } sub related { my $self = shift; my ($event) = @_; my $tracea = $self->trace or return undef; my $traceb = $event->trace or return undef; my $uuida = $tracea->uuid; my $uuidb = $traceb->uuid; if ($uuida && $uuidb) { return 1 if $uuida eq $uuidb; return 0; } my $siga = $tracea->signature or return undef; my $sigb = $traceb->signature or return undef; return 1 if $siga eq $sigb; return 0; } sub add_hub { my $self = shift; unshift @{$self->{+HUBS}} => @_; } sub add_amnesty { my $self = shift; for my $am (@_) { $am = {%$am} if ref($am) ne 'ARRAY'; $am = Test2::EventFacet::Amnesty->new($am); push @{$self->{+AMNESTY}} => $am; } } sub eid { $_[0]->{+_EID} ||= gen_uid() } sub common_facet_data { my $self = shift; my %out; $out{about} = {package => ref($self) || undef}; if (my $uuid = $self->uuid) { $out{about}->{uuid} = $uuid; } $out{about}->{eid} = $self->{+_EID} || $self->eid; if (my $trace = $self->trace) { $out{trace} = { %$trace }; } if (my $hubs = $self->hubs) { $out{hubs} = $hubs; } $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}] if $self->{+AMNESTY}; if (my $meta = $self->meta_facet_data) { $out{meta} = $meta; } return \%out; } sub meta_facet_data { my $self = shift; my $key = Test2::Util::ExternalMeta::META_KEY(); my $hash = $self->{$key} or return undef; return {%$hash}; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = $self->summary || undef; $out->{about}->{no_display} = $self->no_display || undef; # Might be undef, we want to preserve that my $terminate = $self->terminate; $out->{control} = { global => $self->global || 0, terminate => $terminate, has_callback => $self->can('callback') == \&callback ? 0 : 1, }; $out->{assert} = { no_debug => 1, # Legacy behavior pass => $self->causes_fail ? 0 : 1, details => $self->summary, } if $self->increments_count; $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id; if (my @plan = $self->sets_plan) { $out->{plan} = {}; $out->{plan}->{count} = $plan[0] if defined $plan[0]; $out->{plan}->{details} = $plan[2] if defined $plan[2]; if ($plan[1]) { $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP'; $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN'; } $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip}; } if ($self->causes_fail && !$out->{assert}) { $out->{errors} = [ { tag => 'FAIL', fail => 1, details => $self->summary, } ]; } my %IGNORE = (trace => 1, about => 1, control => 1); my $do_info = !grep { !$IGNORE{$_} } keys %$out; if ($do_info && !$self->no_display && $self->diagnostics) { $out->{info} = [ { tag => 'DIAG', debug => 1, details => $self->summary, } ]; } return $out; } sub facets { my $self = shift; my %out; my $data = $self->facet_data; my @errors = $self->validate_facet_data($data); die join "\n" => @errors if @errors; for my $facet (keys %$data) { my $class = $self->load_facet($facet); my $val = $data->{$facet}; unless($class) { $out{$facet} = $val; next; } my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0; if ($is_list) { $out{$facet} = [map { $class->new($_) } @$val]; } else { $out{$facet} = $class->new($val); } } return \%out; } sub validate_facet_data { my $class_or_self = shift; my ($f, %params); $f = shift if @_ && (reftype($_[0]) || '') eq 'HASH'; %params = @_; $f ||= $class_or_self->facet_data if blessed($class_or_self); croak "No facet data" unless $f; my @errors; for my $k (sort keys %$f) { my $fclass = $class_or_self->load_facet($k); push @errors => "Could not find a facet class for facet '$k'" if $params{require_facet_class} && !$fclass; next unless $fclass; my $v = $f->{$k}; next unless defined($v); # undef is always fine my $is_list = $fclass->is_list(); my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0; push @errors => "Facet '$k' should be a list, but got a single item ($v)" if $is_list && !$got_list; push @errors => "Facet '$k' should not be a list, but got a a list ($v)" if $got_list && !$is_list; } return @errors; } sub nested { my $self = shift; Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead") if $ENV{AUTHOR_TESTING}; if (my $hubs = $self->{+HUBS}) { return $hubs->[0]->{nested} if @$hubs; } my $trace = $self->{+TRACE} or return undef; return $trace->{nested}; } sub in_subtest { my $self = shift; Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead") if $ENV{AUTHOR_TESTING}; my $hubs = $self->{+HUBS}; if ($hubs && @$hubs) { return undef unless $hubs->[0]->{nested}; return $hubs->[0]->{hid} } my $trace = $self->{+TRACE} or return undef; return undef unless $trace->{nested}; return $trace->{hid}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event - Base class for events =head1 DESCRIPTION Base class for all event objects that get passed through L. =head1 SYNOPSIS package Test2::Event::MyEvent; use strict; use warnings; # This will make our class an event subclass (required) use base 'Test2::Event'; # Add some accessors (optional) # You are not obligated to use HashBase, you can use any object tool you # want, or roll your own accessors. use Test2::Util::HashBase qw/foo bar baz/; # Use this if you want the legacy API to be written for you, for this to # work you will need to implement a facet_data() method. use Test2::Util::Facets2Legacy; # Chance to initialize some defaults sub init { my $self = shift; # no other args in @_ $self->set_foo('xxx') unless defined $self->foo; ... } # This is the new way for events to convey data to the Test2 system sub facet_data { my $self = shift; # Get common facets such as 'about', 'trace' 'amnesty', and 'meta' my $facet_data = $self->common_facet_data(); # Are you making an assertion? $facet_data->{assert} = {pass => 1, details => 'my assertion'}; ... return $facet_data; } 1; =head1 METHODS =head2 GENERAL =over 4 =item $trace = $e->trace Get a snapshot of the L as it was when this event was generated =item $bool_or_undef = $e->related($e2) Check if 2 events are related. In this case related means their traces share a signature meaning they were created with the same context (or at the very least by contexts which share an id, which is the same thing unless someone is doing something very bad). This can be used to reliably link multiple events created by the same tool. For instance a failing test like C will generate 2 events, one being a L, the other being a L, both of these events are related having been created under the same context and by the same initial tool (though multiple tools may have been nested under the initial one). This will return C if the relationship cannot be checked, which happens if either event has an incomplete or missing trace. This will return C<0> if the traces are complete, but do not match. C<1> will be returned if there is a match. =item $e->add_amnesty({tag => $TAG, details => $DETAILS}); This can be used to add amnesty to this event. Amnesty only affects failing assertions in most cases, but some formatters may display them for passing assertions, or even non-assertions as well. Amnesty will prevent a failed assertion from causing the overall test to fail. In other words it marks a failure as expected and allowed. B This is how 'TODO' is implemented under the hood. TODO is essentially amnesty with the 'TODO' tag. The details are the reason for the TODO. =item $uuid = $e->uuid If UUID tagging is enabled (See L) then any event that has made its way through a hub will be tagged with a UUID. A newly created event will not yet be tagged in most cases. =item $class = $e->load_facet($name) This method is used to load a facet by name (or key). It will attempt to load the facet class, if it succeeds it will return the class it loaded. If it fails it will return C. This caches the result at the class level so that future calls will be faster. The C<$name> variable should be the key used to access the facet in a facets hashref. For instance the assertion facet has the key 'assert', the information facet has the 'info' key, and the error facet has the key 'errors'. You may include or omit the 's' at the end of the name, the method is smart enough to try both the 's' and no-'s' forms, it will check what you provided first, and if that is not found it will add or strip the 's and try again. =item @classes = $e->FACET_TYPES() =item @classes = Test2::Event->FACET_TYPES() This returns a list of all facets that have been loaded using the C method. This will not return any classes that have not been loaded, or have been loaded directly without a call to C. B The core facet types are automatically loaded and populated in this list. =back =head2 NEW API =over 4 =item $hashref = $e->common_facet_data(); This can be used by subclasses to generate a starting facet data hashref. This will populate the hashref with the trace, meta, amnesty, and about facets. These facets are nearly always produced the same way for all events. =item $hashref = $e->facet_data() If you do not override this then the default implementation will attempt to generate facets from the legacy API. This generation is limited only to what the legacy API can provide. It is recommended that you override this method and write out explicit facet data. =item $hashref = $e->facets() This takes the hashref from C and blesses each facet into the proper C subclass. If no class can be found for any given facet it will be passed along unchanged. =item @errors = $e->validate_facet_data(); =item @errors = $e->validate_facet_data(%params); =item @errors = $e->validate_facet_data(\%facets, %params); =item @errors = Test2::Event->validate_facet_data(%params); =item @errors = Test2::Event->validate_facet_data(\%facets, %params); This method will validate facet data and return a list of errors. If no errors are found this will return an empty list. This can be called as an object method with no arguments, in which case the C method will be called to get the facet data to be validated. When used as an object method the C<\%facet_data> argument may be omitted. When used as a class method the C<\%facet_data> argument is required. Remaining arguments will be slurped into a C<%params> hash. Currently only 1 parameter is defined: =over 4 =item require_facet_class => $BOOL When set to true (default is false) this will reject any facets where a facet class cannot be found. Normally facets without classes are assumed to be custom and are ignored. =back =back =head3 WHAT ARE FACETS? Facets are how events convey their purpose to the Test2 internals and formatters. An event without facets will have no intentional effect on the overall test state, and will not be displayed at all by most formatters, except perhaps to say that an event of an unknown type was seen. Facets are produced by the C subroutine, which you should nearly-always override. C is expected to return a hashref where each key is the facet type, and the value is either a hashref with the data for that facet, or an array of hashrefs. Some facets must be defined as single hashrefs, some must be defined as an array of hashrefs, No facets allow both. C B bless the data it returns, the main hashref, and nested facet hashrefs B be bare, though items contained within each facet may be blessed. The data returned by this method B also be copies of the internal data in order to prevent accidental state modification. C takes the data from C and blesses it into the C packages. This is rarely used however, the EventFacet packages are primarily for convenience and documentation. The EventFacet classes are not used at all internally, instead the raw data is used. Here is a list of facet types by package. The packages are not used internally, but are where the documentation for each type is kept. B Every single facet type has the C<'details'> field. This field is always intended for human consumption, and when provided, should explain the 'why' for the facet. All other fields are facet specific. =over 4 =item about => {...} L This contains information about the event itself such as the event package name. The C
field for this facet is an overall summary of the event. =item assert => {...} L This facet is used if an assertion was made. The C
field of this facet is the description of the assertion. =item control => {...} L This facet is used to tell the L about special actions the event causes. Things like halting all testing, terminating the current test, etc. In this facet the C
field explains why any special action was taken. B This is how bail-out is implemented. =item meta => {...} L The meta facet contains all the meta-data attached to the event. In this case the C
field has no special meaning, but may be present if something sets the 'details' meta-key on the event. =item parent => {...} L This facet contains nested events and similar details for subtests. In this facet the C
field will typically be the name of the subtest. =item plan => {...} L This facet tells the system that a plan has been set. The C
field of this is usually left empty, but when present explains why the plan is what it is, this is most useful if the plan is to skip-all. =item trace => {...} L This facet contains information related to when and where the event was generated. This is how the test file and line number of a failure is known. This facet can also help you to tell if tests are related. In this facet the C
field overrides the "failed at test_file.t line 42." message provided on assertion failure. =item amnesty => [{...}, ...] L The amnesty facet is a list instead of a single item, this is important as amnesty can come from multiple places at once. For each instance of amnesty the C
field explains why amnesty was granted. B Outside of formatters amnesty only acts to forgive a failing assertion. =item errors => [{...}, ...] L The errors facet is a list instead of a single item, any number of errors can be listed. In this facet C
describes the error, or may contain the raw error message itself (such as an exception). In perl exception may be blessed objects, as such the raw data for this facet may contain nested items which are blessed. Not all errors are considered fatal, there is a C field that must be set for an error to cause the test to fail. B This facet is unique in that the field name is 'errors' while the package is 'Error'. This is because this is the only facet type that is both a list, and has a name where the plural is not the same as the singular. This may cause some confusion, but I feel it will be less confusing than the alternative. =item info => [{...}, ...] L The 'info' facet is a list instead of a single item, any quantity of extra information can be attached to an event. Some information may be critical diagnostics, others may be simply commentary in nature, this is determined by the C flag. For this facet the C
flag is the info itself. This info may be a string, or it may be a data structure to display. This is one of the few facet types that may contain blessed items. =back =head2 LEGACY API =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. =item $id = $e->in_subtest If the event is inside a subtest this should have the subtest ID. =item $id = $e->subtest_id If the event is a final subtest event, this should contain the subtest ID. =back =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at 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 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 Simple.pm100644001750001750 1451714772042322 20021 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Testpackage Test::Simple; use 5.006; use strict; our $VERSION = '1.302210'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok); my $CLASS = __PACKAGE__; =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first!> ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the C function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); C is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. C prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) return $CLASS->builder->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets L know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) && ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test 'Rating() get' # in t/film.t at line 14. ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.6.0. Test::Simple is thread-safe in perl 5.8.1 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at L. Test::Simple is 100% forward compatible with L (i.e. you can just use L instead of Test::Simple in your programs and things will still work). =back Look in L's SEE ALSO for more testing modules. =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut 1; Tester.pm100644001750001750 4357514772042322 20044 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Testuse strict; package Test::Tester; BEGIN { if (*Test::Builder::new{CODE}) { warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)" } } use Test::Builder; use Test::Tester::CaptureRunner; use Test::Tester::Delegate; require Exporter; our $VERSION = '1.302210'; our @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); our @ISA = qw( Exporter ); my $Test = Test::Builder->new; my $Capture = Test::Tester::Capture->new; my $Delegator = Test::Tester::Delegate->new; $Delegator->{Object} = $Test; my $runner = Test::Tester::CaptureRunner->new; my $want_space = $ENV{TESTTESTERSPACE}; sub show_space { $want_space = 1; } my $colour = ''; my $reset = ''; if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR}) { if (eval { require Term::ANSIColor; 1 }) { eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms my ($f, $b) = split(",", $want_colour); $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); $reset = Term::ANSIColor::color("reset"); } } sub new_new { return $Delegator; } sub capture { return Test::Tester::Capture->new; } sub fh { # experiment with capturing output, I don't like it $runner = Test::Tester::FHRunner->new; return $Test; } sub find_run_tests { my $d = 1; my $found = 0; while ((not $found) and (my ($sub) = (caller($d))[3]) ) { # print "$d: $sub\n"; $found = ($sub eq "Test::Tester::run_tests"); $d++; } # die "Didn't find 'run_tests' in caller stack" unless $found; return $d; } sub run_tests { local($Delegator->{Object}) = $Capture; $runner->run_tests(@_); return ($runner->get_premature, $runner->get_results); } sub check_test { my $test = shift; my $expect = shift; my $name = shift; $name = "" unless defined($name); @_ = ($test, [$expect], $name); goto &check_tests; } sub check_tests { my $test = shift; my $expects = shift; my $name = shift; $name = "" unless defined($name); my ($prem, @results) = eval { run_tests($test, $name) }; $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@); $Test->ok(! length($prem), "Test '$name' no premature diagnostication") || $Test->diag("Before any testing anything, your tests said\n$prem"); local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_results(\@results, $expects, $name); return ($prem, @results); } sub cmp_field { my ($result, $expect, $field, $desc) = @_; if (defined $expect->{$field}) { $Test->is_eq($result->{$field}, $expect->{$field}, "$desc compare $field"); } } sub cmp_result { my ($result, $expect, $name) = @_; my $sub_name = $result->{name}; $sub_name = "" unless defined($name); my $desc = "subtest '$sub_name' of '$name'"; { local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_field($result, $expect, "ok", $desc); cmp_field($result, $expect, "actual_ok", $desc); cmp_field($result, $expect, "type", $desc); cmp_field($result, $expect, "reason", $desc); cmp_field($result, $expect, "name", $desc); } # if we got no depth then default to 1 my $depth = 1; if (exists $expect->{depth}) { $depth = $expect->{depth}; } # if depth was explicitly undef then don't test it if (defined $depth) { $Test->is_eq($result->{depth}, $depth, "checking depth") || $Test->diag('You need to change $Test::Builder::Level'); } if (defined(my $exp = $expect->{diag})) { my $got = ''; if (ref $exp eq 'Regexp') { if (not $Test->like($result->{diag}, $exp, "subtest '$sub_name' of '$name' compare diag")) { $got = $result->{diag}; } } else { # if there actually is some diag then put a \n on the end if it's not # there already $exp .= "\n" if (length($exp) and $exp !~ /\n$/); if (not $Test->ok($result->{diag} eq $exp, "subtest '$sub_name' of '$name' compare diag")) { $got = $result->{diag}; } } if ($got) { my $glen = length($got); my $elen = length($exp); for ($got, $exp) { my @lines = split("\n", $_); $_ = join("\n", map { if ($want_space) { $_ = $colour.escape($_).$reset; } else { "'$colour$_$reset'" } } @lines); } $Test->diag(<32 and $c<125) or $c == 10) { $res .= $char; } else { $res .= sprintf('\x{%x}', $c) } } return $res; } sub cmp_results { my ($results, $expects, $name) = @_; $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); for (my $i = 0; $i < @$expects; $i++) { my $expect = $expects->[$i]; my $result = $results->[$i]; local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_result($result, $expect, $name); } } ######## nicked from Test::More sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; { no warnings 'redefine'; *Test::Builder::new = \&new_new; } goto &plan; } sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } ############ 1; __END__ =head1 NAME Test::Tester - Ease testing test modules built with Test::Builder =head1 SYNOPSIS use Test::Tester tests => 6; use Test::MyStyle; check_test( sub { is_mystyle_eq("this", "that", "not eq"); }, { ok => 0, # expect this to fail name => "not eq", diag => "Expected: 'this'\nGot: 'that'", } ); or use Test::Tester tests => 6; use Test::MyStyle; check_test( sub { is_mystyle_qr("this", "that", "not matching"); }, { ok => 0, # expect this to fail name => "not matching", diag => qr/Expected: 'this'\s+Got: 'that'/, } ); or use Test::Tester; use Test::More tests => 3; use Test::MyStyle; my ($premature, @results) = run_tests( sub { is_database_alive("dbname"); } ); # now use Test::More::like to check the diagnostic output like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); =head1 DESCRIPTION If you have written a test module based on Test::Builder then Test::Tester allows you to test it with the minimum of effort. =head1 HOW TO USE (THE EASY WAY) From version 0.08 Test::Tester no longer requires you to included anything special in your test modules. All you need to do is use Test::Tester; in your test script B any other Test::Builder based modules and away you go. Other modules based on Test::Builder can be used to help with the testing. In fact you can even use functions from your module to test other functions from the same module (while this is possible it is probably not a good idea, if your module has bugs, then using it to test itself may give the wrong answers). The easiest way to test is to do something like check_test( sub { is_mystyle_eq("this", "that", "not eq") }, { ok => 0, # we expect the test to fail name => "not eq", diag => "Expected: 'this'\nGot: 'that'", } ); this will execute the is_mystyle_eq test, capturing its results and checking that they are what was expected. You may need to examine the test results in a more flexible way, for example, the diagnostic output may be quite long or complex or it may involve something that you cannot predict in advance like a timestamp. In this case you can get direct access to the test results: my ($premature, @results) = run_tests( sub { is_database_alive("dbname"); } ); like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); or check_test( sub { is_mystyle_qr("this", "that", "not matching") }, { ok => 0, # we expect the test to fail name => "not matching", diag => qr/Expected: 'this'\s+Got: 'that'/, } ); We cannot predict how long the database ping will take so we use Test::More's like() test to check that the diagnostic string is of the right form. =head1 HOW TO USE (THE HARD WAY) I Make your module use the Test::Tester::Capture object instead of the Test::Builder one. How to do this depends on your module but assuming that your module holds the Test::Builder object in $Test and that all your test routines access it through $Test then providing a function something like this sub set_builder { $Test = shift; } should allow your test scripts to do Test::YourModule::set_builder(Test::Tester->capture); and after that any tests inside your module will captured. =head1 TEST RESULTS The result of each test is captured in a hash. These hashes are the same as the hashes returned by Test::Builder->details but with a couple of extra fields. These fields are documented in L in the details() function =over 2 =item ok Did the test pass? =item actual_ok Did the test really pass? That is, did the pass come from Test::Builder->ok() or did it pass because it was a TODO test? =item name The name supplied for the test. =item type What kind of test? Possibilities include, skip, todo etc. See L for more details. =item reason The reason for the skip, todo etc. See L for more details. =back These fields are exclusive to Test::Tester. =over 2 =item diag Any diagnostics that were output for the test. This only includes diagnostics output B the test result is declared. Note that Test::Builder ensures that any diagnostics end in a \n and it in earlier versions of Test::Tester it was essential that you have the final \n in your expected diagnostics. From version 0.10 onward, Test::Tester will add the \n if you forgot it. It will not add a \n if you are expecting no diagnostics. See below for help tracking down hard to find space and tab related problems. =item depth This allows you to check that your test module is setting the correct value for $Test::Builder::Level and thus giving the correct file and line number when a test fails. It is calculated by looking at caller() and $Test::Builder::Level. It should count how many subroutines there are before jumping into the function you are testing. So for example in run_tests( sub { my_test_function("a", "b") } ); the depth should be 1 and in sub deeper { my_test_function("a", "b") } run_tests(sub { deeper() }); depth should be 2, that is 1 for the sub {} and one for deeper(). This might seem a little complex but if your tests look like the simple examples in this doc then you don't need to worry as the depth will always be 1 and that's what Test::Tester expects by default. B: if you do not specify a value for depth in check_test() then it automatically compares it against 1, if you really want to skip the depth test then pass in undef. B: depth will not be correctly calculated for tests that run from a signal handler or an END block or anywhere else that hides the call stack. =back Some of Test::Tester's functions return arrays of these hashes, just like Test::Builder->details. That is, the hash for the first test will be array element 1 (not 0). Element 0 will not be a hash it will be a string which contains any diagnostic output that came before the first test. This should usually be empty, if it's not, it means something output diagnostics before any test results showed up. =head1 SPACES AND TABS Appearances can be deceptive, especially when it comes to emptiness. If you are scratching your head trying to work out why Test::Tester is saying that your diagnostics are wrong when they look perfectly right then the answer is probably whitespace. From version 0.10 on, Test::Tester surrounds the expected and got diag values with single quotes to make it easier to spot trailing whitespace. So in this example # Got diag (5 bytes): # 'abcd ' # Expected diag (4 bytes): # 'abcd' it is quite clear that there is a space at the end of the first string. Another way to solve this problem is to use colour and inverse video on an ANSI terminal, see below COLOUR below if you want this. Unfortunately this is sometimes not enough, neither colour nor quotes will help you with problems involving tabs, other non-printing characters and certain kinds of problems inherent in Unicode. To deal with this, you can switch Test::Tester into a mode whereby all "tricky" characters are shown as \{xx}. Tricky characters are those with ASCII code less than 33 or higher than 126. This makes the output more difficult to read but much easier to find subtle differences between strings. To turn on this mode either call C in your test script or set the C environment variable to be a true value. The example above would then look like # Got diag (5 bytes): # abcd\x{20} # Expected diag (4 bytes): # abcd =head1 COLOUR If you prefer to use colour as a means of finding tricky whitespace characters then you can set the C environment variable to a comma separated pair of colours, the first for the foreground, the second for the background. For example "white,red" will print white text on a red background. This requires the Term::ANSIColor module. You can specify any colour that would be acceptable to the Term::ANSIColor::color function. If you spell colour differently, that's no problem. The C variable also works (if both are set then the British spelling wins out). =head1 EXPORTED FUNCTIONS =head3 ($premature, @results) = run_tests(\&test_sub) \&test_sub is a reference to a subroutine. run_tests runs the subroutine in $test_sub and captures the results of any tests inside it. You can run more than 1 test inside this subroutine if you like. $premature is a string containing any diagnostic output from before the first test. @results is an array of test result hashes. =head3 cmp_result(\%result, \%expect, $name) \%result is a ref to a test result hash. \%expect is a ref to a hash of expected values for the test result. cmp_result compares the result with the expected values. If any differences are found it outputs diagnostics. You may leave out any field from the expected result and cmp_result will not do the comparison of that field. =head3 cmp_results(\@results, \@expects, $name) \@results is a ref to an array of test results. \@expects is a ref to an array of hash refs. cmp_results checks that the results match the expected results and if any differences are found it outputs diagnostics. It first checks that the number of elements in \@results and \@expects is the same. Then it goes through each result checking it against the expected result as in cmp_result() above. =head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) \&test_sub is a reference to a subroutine. \@expect is a ref to an array of hash refs which are expected test results. check_tests combines run_tests and cmp_tests into a single call. It also checks if the tests died at any stage. It returns the same values as run_tests, so you can further examine the test results if you need to. =head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name) \&test_sub is a reference to a subroutine. \%expect is a ref to an hash of expected values for the test result. check_test is a wrapper around check_tests. It combines run_tests and cmp_tests into a single call, checking if the test died. It assumes that only a single test is run inside \&test_sub and include a test to make sure this is true. It returns the same values as run_tests, so you can further examine the test results if you need to. =head3 show_space() Turn on the escaping of characters as described in the SPACES AND TABS section. =head1 HOW IT WORKS Normally, a test module (let's call it Test:MyStyle) calls Test::Builder->new to get the Test::Builder object. Test::MyStyle calls methods on this object to record information about test results. When Test::Tester is loaded, it replaces Test::Builder's new() method with one which returns a Test::Tester::Delegate object. Most of the time this object behaves as the real Test::Builder object. Any methods that are called are delegated to the real Test::Builder object so everything works perfectly. However once we go into test mode, the method calls are no longer passed to the real Test::Builder object, instead they go to the Test::Tester::Capture object. This object seems exactly like the real Test::Builder object, except, instead of outputting test results and diagnostics, it just records all the information for later analysis. =head1 CAVEATS Support for calling Test::Builder->note is minimal. It's implemented as an empty stub, so modules that use it will not crash but the calls are not recorded for testing purposes like the others. Patches welcome. =head1 SEE ALSO L the source of testing goodness. L for an alternative approach to the problem tackled by Test::Tester - captures the strings output by Test::Builder. This means you cannot get separate access to the individual pieces of information and you must predict B what your test will output. =head1 AUTHOR This module is copyright 2005 Fergal Daly , some parts are based on other people's work. Plan handling lifted from Test::More. written by Michael G Schwern . Test::Tester::Capture is a cut down and hacked up version of Test::Builder. Test::Builder was written by chromatic and Michael G Schwern . =head1 LICENSE Under the same license as Perl itself See L =cut use000755001750001750 014772042322 16636 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Testok.pm100644001750001750 252414772042322 17750 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/usepackage Test::use::ok; use 5.005; our $VERSION = '1.302210'; __END__ =head1 NAME Test::use::ok - Alternative to Test::More::use_ok =head1 SYNOPSIS use ok 'Some::Module'; =head1 DESCRIPTION According to the B documentation, it is recommended to run C inside a C block, so functions are exported at compile-time and prototypes are properly honored. That is, instead of writing this: use_ok( 'Some::Module' ); use_ok( 'Other::Module' ); One should write this: BEGIN { use_ok( 'Some::Module' ); } BEGIN { use_ok( 'Other::Module' ); } However, people often either forget to add C, or mistakenly group C with other tests in a single C block, which can create subtle differences in execution order. With this module, simply change all C in test scripts to C, and they will be executed at C time. The explicit space after C makes it clear that this is a single compile-time action. =head1 SEE ALSO L =head1 MAINTAINER =over 4 =item Chad Granum Eexodist@cpan.orgE =back =encoding utf8 =head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L. This work is published from Taiwan. L =cut Bundle.t100644001750001750 13714772042322 20007 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse Test2::Bundle::Extended; use Test2::Bundle; pass("Loaded Test2::Bundle"); done_testing; Plugin.t100644001750001750 13714772042322 20034 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse Test2::Bundle::Extended; use Test2::Plugin; pass("Loaded Test2::Plugin"); done_testing; skipall.t100644001750001750 74114772042322 17772 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More; my $Test = Test::Builder->create; $Test->plan(tests => 2); my $out = ''; my $err = ''; { my $tb = Test::More->builder; $tb->output(\$out); $tb->failure_output(\$err); plan 'skip_all'; } END { $Test->is_eq($out, "1..0 # SKIP\n"); $Test->is_eq($err, ""); } no_plan.t100644001750001750 151014772042322 17774 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More tests => 7; my $tb = Test::Builder->create; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; #line 20 ok !eval { $tb->$plan(tests => undef) }; is($@, "Got an undefined number of tests at $0 line 20.\n"); #line 24 ok !eval { $tb->$plan(tests => 0) }; is($@, "You said to run 0 tests at $0 line 24.\n"); { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= join '', @_ }; #line 31 ok $tb->$plan(no_plan => 1); is( $warning, "no_plan takes no arguments at $0 line 31.\n" ); is $tb->has_plan, 'no_plan'; } explain.t100644001750001750 110614772042322 20007 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More tests => 5; can_ok "main", "explain"; is_deeply [explain("foo")], ["foo"]; is_deeply [explain("foo", "bar")], ["foo", "bar"]; # Avoid future dump formatting changes from breaking tests by just eval'ing # the dump is_deeply [map { eval $_ } explain([], {})], [[], {}]; is_deeply [map { eval $_ } explain(23, [42,91], 99)], [23, [42, 91], 99]; missing.t100644001750001750 211514772042322 20021 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy# HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 2); sub is { $TB->is_eq(@_) } package main; require Test::Simple; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; Test::Simple->import(tests => 5); #line 30 ok(1, 'Foo'); ok(0, 'Bar'); ok(1, '1 2 3'); END { My::Test::is($$out, <import(skip_all => "threads are not supported"); } } use threads; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; use Test::Builder; my $Test = Test::Builder->new; $Test->exported_to('main'); $Test->plan(tests => 6); for(1..5) { 'threads'->create(sub { $Test->ok(1,"Each of these should app the test number") })->join; } $Test->is_num($Test->current_test(), 5,"Should be five"); capture.t100644001750001750 75014772042322 17776 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use Test::Tester; my $Test = Test::Builder->new; $Test->plan(tests => 3); my $cap; $cap = Test::Tester->capture; { no warnings 'redefine'; sub Test::Tester::find_run_tests { return 0}; } local $Test::Builder::Level = 0; { my $cur = $cap->current_test; $Test->is_num($cur, 0, "current test"); eval {$cap->current_test(2)}; $Test->ok($@, "can't set test_num"); } { $cap->ok(1, "a test"); my @res = $cap->details; $Test->is_num(scalar @res, 1, "res count"); } SmallTest.pm100644001750001750 47314772042322 17760 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libuse strict; use warnings; package SmallTest; require Exporter; our @ISA = qw( Exporter ); our @EXPORT = qw( ok is_eq is_num ); use Test::Builder; my $Test = Test::Builder->new; sub ok { $Test->ok(@_); } sub is_eq { $Test->is_eq(@_); } sub is_num { $Test->is_num(@_); } sub getTest { return $Test; } 1; Bundle.pm100644001750001750 301214772042322 20027 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Bundle; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Plugin.pm100644001750001750 351014772042322 20057 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Plugin; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Manual.pm100644001750001750 275514772042322 20050 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Manual; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Builder.pm100644001750001750 17660114772042322 20201 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Testpackage Test::Builder; use 5.006; use strict; use warnings; our $VERSION = '1.302210'; use Scalar::Util qw/blessed reftype weaken/; use Test2::Util qw/USE_THREADS try get_tid/; use Test2::API qw/context release/; # Make Test::Builder thread-safe for ithreads. BEGIN { warn "Test::Builder was loaded after Test2 initialization, this is not recommended." if Test2::API::test2_init_done() || Test2::API::test2_load_done(); if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) { require Test2::IPC; require Test2::IPC::Driver::Files; Test2::IPC::Driver::Files->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_no_wait(1); } } use Test2::Event::Subtest; use Test2::Hub::Subtest; use Test::Builder::Formatter; use Test::Builder::TodoDiag; our $Level = 1; our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; sub _add_ts_hooks { my $self = shift; my $hub = $self->{Stack}->top; # Take a reference to the hash key, we do this to avoid closing over $self # which is the singleton. We use a reference because the value could change # in rare cases. my $epkgr = \$self->{Exported_To}; #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1}); $hub->pre_filter( sub { my ($active_hub, $e) = @_; my $epkg = $$epkgr; my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef; no strict 'refs'; no warnings 'once'; my $todo; $todo = ${"$cpkg\::TODO"} if $cpkg; $todo = ${"$epkg\::TODO"} if $epkg && !$todo; return $e unless defined($todo); return $e unless length($todo); # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; $e->set_todo($todo) if $e->can('set_todo'); $e->add_amnesty({tag => 'TODO', details => $todo}); # Set todo on ok's if ($e->isa('Test2::Event::Ok')) { $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $todo; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1, intercept_inherit => { clean => sub { my %params = @_; my $state = $params{state}; my $trace = $params{trace}; my $epkg = $$epkgr; my $cpkg = $trace->{frame}->[0]; no strict 'refs'; no warnings 'once'; $state->{+__PACKAGE__} = {}; $state->{+__PACKAGE__}->{"$cpkg\::TODO"} = ${"$cpkg\::TODO"} if $cpkg; $state->{+__PACKAGE__}->{"$epkg\::TODO"} = ${"$epkg\::TODO"} if $epkg; ${"$cpkg\::TODO"} = undef if $cpkg; ${"$epkg\::TODO"} = undef if $epkg; }, restore => sub { my %params = @_; my $state = $params{state}; no strict 'refs'; no warnings 'once'; for my $item (keys %{$state->{+__PACKAGE__}}) { no strict 'refs'; no warnings 'once'; ${"$item"} = $state->{+__PACKAGE__}->{$item}; } }, }, ); } { no warnings; INIT { use warnings; Test2::API::test2_load() unless Test2::API::test2_in_preload(); } } sub new { my($class) = shift; unless($Test) { $Test = $class->create(singleton => 1); Test2::API::test2_add_callback_post_load( sub { $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0; $Test->reset(singleton => 1); $Test->_add_ts_hooks; } ); # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So # we only want the level to change if $Level != 1. # TB->ctx compensates for this later. Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 }); Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) }); Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc(); } return $Test; } sub create { my $class = shift; my %params = @_; my $self = bless {}, $class; if ($params{singleton}) { $self->{Stack} = Test2::API::test2_stack(); } else { $self->{Stack} = Test2::API::Stack->new; $self->{Stack}->new_hub( formatter => Test::Builder::Formatter->new, ipc => Test2::API::test2_ipc(), ); $self->reset(%params); $self->_add_ts_hooks; } return $self; } sub ctx { my $self = shift; context( # 1 for our frame, another for the -1 off of $Level in our hook at the top. level => 2, fudge => 1, stack => $self->{Stack}, hub => $self->{Hub}, wrapped => 1, @_ ); } sub parent { my $self = shift; my $ctx = $self->ctx; my $chub = $self->{Hub} || $ctx->hub; $ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); my $parent = $meta->{parent}; return undef unless $parent; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $parent, }, blessed($self); } sub child { my( $self, $name ) = @_; $name ||= "Child of " . $self->name; my $ctx = $self->ctx; my $parent = $ctx->hub; my $pmeta = $parent->meta(__PACKAGE__, {}); $self->croak("You already have a child named ($pmeta->{child}) running") if $pmeta->{child}; $pmeta->{child} = $name; # Clear $TODO for the child. my $orig_TODO = $self->find_TODO(undef, 1, undef); my $subevents = []; my $hub = $ctx->stack->new_hub( class => 'Test2::Hub::Subtest', ); $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; return $e; }, inherit => 1) if $orig_TODO; $hub->listen(sub { push @$subevents => $_[1] }); $hub->set_nested( $parent->nested + 1 ); my $meta = $hub->meta(__PACKAGE__, {}); $meta->{Name} = $name; $meta->{TODO} = $orig_TODO; $meta->{TODO_PKG} = $ctx->trace->package; $meta->{parent} = $parent; $meta->{Test_Results} = []; $meta->{subevents} = $subevents; $meta->{subtest_id} = $hub->id; $meta->{subtest_uuid} = $hub->uuid; $meta->{subtest_buffered} = $parent->format ? 0 : 1; $self->_add_ts_hooks; $ctx->release; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self); } sub finalize { my $self = shift; my $ok = 1; ($ok) = @_ if @_; my $st_ctx = $self->ctx; my $chub = $self->{Hub} || return $st_ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); if ($meta->{child}) { $self->croak("Can't call finalize() with child ($meta->{child}) active"); } local $? = 0; # don't fail if $subtests happened to set $? nonzero $self->{Stack}->pop($chub); $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO}); my $parent = $self->parent; my $ctx = $parent->ctx; my $trace = $ctx->trace; delete $ctx->hub->meta(__PACKAGE__, {})->{child}; $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1) if $ok && $chub->count && !$chub->no_ending && !$chub->ended; my $plan = $chub->plan || 0; my $count = $chub->count; my $failed = $chub->failed; my $passed = $chub->is_passing; my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan; if ($count && $num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $st_ctx->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $st_ctx->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $st_ctx->diag(<<"FAIL"); All assertions inside the subtest passed, but errors were encountered. FAIL } $st_ctx->release; unless ($chub->bailed_out) { my $plan = $chub->plan; if ( $plan && $plan eq 'SKIP' ) { $parent->skip($chub->skip_reason, $meta->{Name}); } elsif ( !$chub->count ) { $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} ); } else { $parent->{subevents} = $meta->{subevents}; $parent->{subtest_id} = $meta->{subtest_id}; $parent->{subtest_uuid} = $meta->{subtest_uuid}; $parent->{subtest_buffered} = $meta->{subtest_buffered}; $parent->ok( $chub->is_passing, $meta->{Name} ); } } $ctx->release; return $chub->is_passing; } sub subtest { my $self = shift; my ($name, $code, @args) = @_; my $ctx = $self->ctx; $ctx->throw("subtest()'s second argument must be a code ref") unless $code && reftype($code) eq 'CODE'; $name ||= "Child of " . $self->name; $_->($name,$code,@args) for Test2::API::test2_list_pre_subtest_callbacks(); $ctx->note("Subtest: $name"); my $child = $self->child($name); my $start_pid = $$; my $st_ctx; my ($ok, $err, $finished, $child_error); T2_SUBTEST_WRAPPER: { my $ctx = $self->ctx; $st_ctx = $ctx->snapshot; $ctx->release; $ok = eval { local $Level = 1; $code->(@args); 1 }; ($err, $child_error) = ($@, $?); # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { $ok = undef; $err = undef; } else { $finished = 1; } } if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) { warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; exit 255; } my $trace = $ctx->trace; if (!$finished) { if(my $bailed = $st_ctx->hub->bailed_out) { my $chub = $child->{Hub}; $self->{Stack}->pop($chub); $ctx->bail($bailed->reason); } my $code = $st_ctx->hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } my $st_hub = $st_ctx->hub; my $plan = $st_hub->plan; my $count = $st_hub->count; if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) { $st_ctx->plan(0) unless defined $plan; $st_ctx->diag('No tests run!'); } $child->finalize($st_ctx->trace); $ctx->release; die $err unless $ok; $? = $child_error if defined $child_error; return $st_hub->is_passing; } sub name { my $self = shift; my $ctx = $self->ctx; release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name}; } sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my ($self, %params) = @_; Test2::API::test2_unset_is_end(); # We leave this a global because it has to be localized and localizing # hash keys is just asking for pain. Also, it was documented. $Level = 1; $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0 unless $params{singleton}; $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->release; unless ($params{singleton}) { $hub->reset_state(); $hub->_tb_reset(); } $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); %$meta = ( Name => $0, Ending => 0, Done_Testing => undef, Skip_All => 0, Test_Results => [], parent => $meta->{parent}, ); $self->{Exported_To} = undef unless $params{singleton}; $self->{Orig_Handles} ||= do { my $format = $ctx->hub->format; my $out; if ($format && $format->isa('Test2::Formatter::TAP')) { $out = $format->handles; } $out ? [@$out] : []; }; $self->use_numbers(1); $self->no_header(0) unless $params{singleton}; $self->no_ending(0) unless $params{singleton}; $self->reset_outputs; $ctx->release; return; } my %plan_cmds = ( no_plan => \&no_plan, skip_all => \&skip_all, tests => \&_plan_tests, ); sub plan { my( $self, $cmd, $arg ) = @_; return unless $cmd; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->throw("You tried to plan twice") if $hub->plan; local $Level = $Level + 1; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; $self->$method($arg); } else { my @args = grep { defined } ( $cmd, $arg ); $ctx->throw("plan() doesn't understand @args"); } release $ctx, 1; } sub _plan_tests { my($self, $arg) = @_; my $ctx = $self->ctx; if($arg) { local $Level = $Level + 1; $self->expected_tests($arg); } elsif( !defined $arg ) { $ctx->throw("Got an undefined number of tests"); } else { $ctx->throw("You said to run 0 tests"); } $ctx->release; } sub expected_tests { my $self = shift; my($max) = @_; my $ctx = $self->ctx; if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; $ctx->plan($max); } my $hub = $ctx->hub; $ctx->release; my $plan = $hub->plan; return 0 unless $plan; return 0 if $plan =~ m/\D/; return $plan; } sub no_plan { my($self, $arg) = @_; my $ctx = $self->ctx; if (defined $ctx->hub->plan) { warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future."; $ctx->release; return; } $ctx->alert("no_plan takes no arguments") if $arg; $ctx->hub->plan('NO PLAN'); release $ctx, 1; } sub done_testing { my($self, $num_tests) = @_; my $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); if ($meta->{Done_Testing}) { my ($file, $line) = @{$meta->{Done_Testing}}[1,2]; local $ctx->hub->{ended}; # OMG This is awful. $self->ok(0, "done_testing() was already called at $file line $line"); $ctx->release; return; } $meta->{Done_Testing} = [$ctx->trace->call]; my $plan = $ctx->hub->plan; my $count = $ctx->hub->count; # If done_testing() specified the number of tests, shut off no_plan if( defined $num_tests ) { $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN'; } elsif ($count && defined $num_tests && $count != $num_tests) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests"); } else { $num_tests = $self->current_test; } if( $self->expected_tests && $num_tests != $self->expected_tests ) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". "but done_testing() expects $num_tests"); } $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN'; $ctx->hub->finalize($ctx->trace, 1); release $ctx, 1; } sub has_plan { my $self = shift; my $ctx = $self->ctx; my $plan = $ctx->hub->plan; $ctx->release; return( $plan ) if $plan && $plan !~ m/\D/; return('no_plan') if $plan && $plan eq 'NO PLAN'; return(undef); } sub skip_all { my( $self, $reason ) = @_; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1; # Work around old perl bug if ($] < 5.020000) { my $begin = 0; my $level = 0; while (my @call = caller($level++)) { last unless @call && $call[0]; next unless $call[3] =~ m/::BEGIN$/; $begin++; last; } # HACK! die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent}; } $reason = "$reason" if defined $reason; $ctx->plan(0, SKIP => $reason); } sub exported_to { my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; } return $self->{Exported_To}; } sub ok { my( $self, $test, $name ) = @_; my $ctx = $self->ctx; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; # In case $name is a string overloaded object, force it to stringify. no warnings qw/uninitialized numeric/; $name = "$name" if defined $name; # Profiling showed that the regex here was a huge time waster, doing the # numeric addition first cuts our profile time from ~300ms to ~50ms $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. Very confusing. ERR use warnings qw/uninitialized numeric/; my $trace = $ctx->{trace}; my $hub = $ctx->{hub}; my $result = { ok => $test, actual_ok => $test, reason => '', type => '', (name => defined($name) ? $name : ''), }; $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results}; my $orig_name = $name; my @attrs; my $subevents = delete $self->{subevents}; my $subtest_id = delete $self->{subtest_id}; my $subtest_uuid = delete $self->{subtest_uuid}; my $subtest_buffered = delete $self->{subtest_buffered}; my $epkg = 'Test2::Event::Ok'; if ($subevents) { $epkg = 'Test2::Event::Subtest'; push @attrs => (subevents => $subevents, subtest_id => $subtest_id, subtest_uuid => $subtest_uuid, buffered => $subtest_buffered); } my $e = bless { trace => bless( {%$trace}, 'Test2::EventFacet::Trace'), pass => $test, name => $name, _meta => {'Test::Builder' => $result}, effective_pass => $test, @attrs, }, $epkg; $hub->send($e); $self->_ok_debug($trace, $orig_name) unless($test); $ctx->release; return $test; } sub _ok_debug { my $self = shift; my ($trace, $orig_name) = @_; my $is_todo = $self->in_todo; my $msg = $is_todo ? "Failed (TODO)" : "Failed"; my (undef, $file, $line) = $trace->call; if (defined $orig_name) { $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]); } else { $self->diag(qq[ $msg test at $file line $line.\n]); } } sub _diag_fh { my $self = shift; local $Level = $Level + 1; return $self->in_todo ? $self->todo_output : $self->failure_output; } sub _unoverload { my ($self, $type, $thing) = @_; return unless ref $$thing; return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') }); { local ($!, $@); require overload; } my $string_meth = overload::Method( $$thing, $type ) || return; $$thing = $$thing->$string_meth(undef, 0); } sub _unoverload_str { my $self = shift; $self->_unoverload( q[""], $_ ) for @_; } sub _unoverload_num { my $self = shift; $self->_unoverload( '0+', $_ ) for @_; for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } } # This is a hack to detect a dualvar such as $! sub _is_dualvar { my( $self, $val ) = @_; # Objects are not dualvars. return 0 if ref $val; no warnings 'numeric'; my $numval = $val + 0; return ($numval != 0 and $numval ne $val ? 1 : 0); } sub is_eq { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '==', $expect, $name ); } sub _diag_fmt { my( $self, $type, $val ) = @_; if( defined $$val ) { if( $type eq 'eq' or $type eq 'ne' ) { # quote and force string context $$val = "'$$val'"; } else { # force numeric context $self->_unoverload_num($val); } } else { $$val = 'undef'; } return; } sub _is_diag { my( $self, $got, $type, $expect ) = @_; $self->_diag_fmt( $type, $_ ) for \$got, \$expect; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: $expect DIAGNOSTIC } sub _isnt_diag { my( $self, $got, $type ) = @_; $self->_diag_fmt( $type, \$got ); local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: anything else DIAGNOSTIC } sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, 'ne' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, '!=' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name ); } sub like { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name ); } sub unlike { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name ); } my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); # Bad, these are not comparison operators. Should we include more? my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; my $ctx = $self->ctx; if ($cmp_ok_bl{$type}) { $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); } my ($test, $succ); my $error; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval my($pack, $file, $line) = $ctx->trace->call(); my $warning_bits = $ctx->trace->warning_bits; # convert this to a code string so the BEGIN doesn't have to close # over it, which can lead to issues with Devel::Cover my $bits_code = defined $warning_bits ? qq["\Q$warning_bits\E"] : 'undef'; # Make sure warnings and location matches the caller. Can't do the # comparison directly in the eval, as closing over variables can # capture them forever when running with Devel::Cover. my $check; $succ = eval qq[ BEGIN {\${^WARNING_BITS} = $bits_code}; #line $line "(eval in cmp_ok) $file" \$check = sub { \$_[0] $type \$_[1] }; 1; ]; if ($succ) { $succ = eval { $test = $check->($got, $expect); 1; }; } $error = $@; } local $Level = $Level + 1; my $ok = $self->ok( $test, $name ); # Treat overloaded objects as numbers if we're asked to do a # numeric comparison. my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' : '_unoverload_str'; $self->diag(<<"END") unless $succ; An error occurred while using $type: ------------------------------------ $error ------------------------------------ END unless($ok) { $self->$unoverload( \$got, \$expect ); if( $type =~ /^(eq|==)$/ ) { $self->_is_diag( $got, $type, $expect ); } elsif( $type =~ /^(ne|!=)$/ ) { if (defined($got) xor defined($expect)) { $self->_cmp_diag( $got, $type, $expect ); } else { $self->_isnt_diag( $got, $type ); } } else { $self->_cmp_diag( $got, $type, $expect ); } } return release $ctx, $ok; } sub _cmp_diag { my( $self, $got, $type, $expect ) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); $got $type $expect DIAGNOSTIC } sub _caller_context { my $self = shift; my( $pack, $file, $line ) = $self->caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; return $code; } sub BAIL_OUT { my( $self, $reason ) = @_; my $ctx = $self->ctx; $self->{Bailed_Out} = 1; $ctx->bail($reason); } { no warnings 'once'; *BAILOUT = \&BAIL_OUT; } sub skip { my( $self, $why, $name ) = @_; $why ||= ''; $name = '' unless defined $name; $self->_unoverload_str( \$why ); my $ctx = $self->ctx; $name = "$name"; $why = "$why"; $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $name =~ s{\n}{\n# }sg; $why =~ s{\n}{\n# }sg; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 1, name => $name, type => 'skip', reason => $why, } unless $self->{no_log_results}; my $tctx = $ctx->snapshot; $tctx->skip('', $why); return release $ctx, 1; } sub todo_skip { my( $self, $why ) = @_; $why ||= ''; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, } unless $self->{no_log_results}; $why =~ s{\n}{\n# }sg; my $tctx = $ctx->snapshot; $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0); return release $ctx, 1; } sub maybe_regex { my( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; my( $re, $opts ); # Check for qr/foo/ if( _is_qr($regex) ) { $usable_regex = $regex; } # Check for '/foo/' or 'm,foo,' elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; } return $usable_regex; } sub _is_qr { my $regex = shift; # is_regexp() checks for regexes in a robust manner, say if they're # blessed. return re::is_regexp($regex) if defined &re::is_regexp; return ref $regex eq 'Regexp'; } sub _regex_ok { my( $self, $thing, $regex, $cmp, $name ) = @_; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless( defined $usable_regex ) { local $Level = $Level + 1; $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { my $test; my $context = $self->_caller_context; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval # No point in issuing an uninit warning, they'll see it in the diagnostics no warnings 'uninitialized'; $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; } $test = !$test if $cmp eq '!~'; local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } unless($ok) { $thing = defined $thing ? "'$thing'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); %s %13s '%s' DIAGNOSTIC } return $ok; } sub is_fh { my $self = shift; my $maybe_fh = shift; return 0 unless defined $maybe_fh; return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob return eval { $maybe_fh->isa("IO::Handle") } || eval { tied($maybe_fh)->can('TIEHANDLE') }; } sub level { my( $self, $level ) = @_; if( defined $level ) { $Level = $level; } return $Level; } sub use_numbers { my( $self, $use_nums ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) { warn "The current formatter does not support 'use_numbers'" if $format; return release $ctx, 0; } $format->set_no_numbers(!$use_nums) if defined $use_nums; return release $ctx, $format->no_numbers ? 0 : 1; } BEGIN { for my $method (qw(no_header no_diag)) { my $set = "set_$method"; my $code = sub { my( $self, $no ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can($set)) { warn "The current formatter does not support '$method'" if $format; $ctx->release; return } $format->$set($no) if defined $no; return release $ctx, $format->$method ? 1 : 0; }; no strict 'refs'; ## no critic *$method = $code; } } sub no_ending { my( $self, $no ) = @_; my $ctx = $self->ctx; $ctx->hub->set_no_ending($no) if defined $no; return release $ctx, $ctx->hub->no_ending; } sub diag { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDERR $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->diag($text); $ctx->release; return 0; } sub note { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDOUT $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->note($text); $ctx->release; return 0; } sub explain { my $self = shift; local ($@, $!); require Data::Dumper; return map { ref $_ ? do { my $dumper = Data::Dumper->new( [$_] ); $dumper->Indent(1)->Terse(1); $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); $dumper->Dump; } : $_ } @_; } sub output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_STD()]; } sub failure_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_ERR()]; } sub todo_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test::Builder::Formatter'); $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test::Builder::Formatter::OUT_TODO()]; } sub _new_fh { my $self = shift; my ($file_or_fh) = shift; my $fh; if ($self->is_fh($file_or_fh)) { $fh = $file_or_fh; } elsif (ref $file_or_fh eq 'SCALAR') { open $fh, ">>", $file_or_fh or $self->croak("Can't open scalar ref $file_or_fh: $!"); } else { open $fh, ">", $file_or_fh or $self->croak("Can't open test output log $file_or_fh: $!"); _autoflush($fh); } return $fh; } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; return; } sub reset_outputs { my $self = shift; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles}; return; } sub carp { my $self = shift; my $ctx = $self->ctx; $ctx->alert(join "", @_); $ctx->release; } sub croak { my $self = shift; my $ctx = $self->ctx; $ctx->throw(join "", @_); $ctx->release; } sub current_test { my( $self, $num ) = @_; my $ctx = $self->ctx; my $hub = $ctx->hub; if( defined $num ) { $hub->set_count($num); unless ($self->{no_log_results}) { # If the test counter is being pushed forward fill in the details. my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; if ($num > @$test_results) { my $start = @$test_results ? @$test_results : 0; for ($start .. $num - 1) { $test_results->[$_] = { 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef }; } } # If backward, wipe history. Its their funeral. elsif ($num < @$test_results) { $#{$test_results} = $num - 1; } } } return release $ctx, $hub->count; } sub is_passing { my $self = shift; my $ctx = $self->ctx; my $hub = $ctx->hub; if( @_ ) { my ($bool) = @_; $hub->set_failed(0) if $bool; $hub->is_passing($bool); } return release $ctx, $hub->is_passing; } sub summary { my($self) = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return map { $_ ? $_->{'ok'} : () } @$data; } sub details { my $self = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return @$data; } sub find_TODO { my( $self, $pack, $set, $new_value ) = @_; my $ctx = $self->ctx; $pack ||= $ctx->trace->package || $self->exported_to; $ctx->release; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; my $old_value = ${ $pack . '::TODO' }; $set and ${ $pack . '::TODO' } = $new_value; return $old_value; } sub todo { my( $self, $pack ) = @_; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return $meta->[-1]->[1] if $meta && @$meta; $pack ||= $ctx->trace->package; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; return ${ $pack . '::TODO' }; } sub in_todo { my $self = shift; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return 1 if $meta && @$meta; my $pack = $ctx->trace->package || return 0; no strict 'refs'; ## no critic no warnings 'once'; my $todo = ${ $pack . '::TODO' }; return 0 unless defined $todo; return 0 if "$todo" eq ''; return 1; } sub todo_start { my $self = shift; my $message = @_ ? shift : ''; my $ctx = $self->ctx; my $hub = $ctx->hub; my $filter = $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; # Set todo on ok's if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) { $e->set_todo($message); $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $message; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1); push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message]; $ctx->release; return; } sub todo_end { my $self = shift; my $ctx = $self->ctx; my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}}; $ctx->throw('todo_end() called without todo_start()') unless $set; $ctx->hub->pre_unfilter($set->[0]); $ctx->release; return; } sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my( $self ) = @_; my $ctx = $self->ctx; my $trace = $ctx->trace; $ctx->release; return wantarray ? $trace->call : $trace->package; } sub _try { my( $self, $code, %opts ) = @_; my $error; my $return; { local $!; # eval can mess up $! local $@; # don't set $@ in the test local $SIG{__DIE__}; # don't trip an outside DIE handler. $return = eval { $code->() }; $error = $@; } die $error if $error and $opts{die_on_fail}; return wantarray ? ( $return, $error ) : $return; } sub _ending { my $self = shift; my ($ctx, $real_exit_code, $new) = @_; unless ($ctx) { my $octx = $self->ctx; $ctx = $octx->snapshot; $octx->release; } return if $ctx->hub->no_ending; return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. return unless $self->{Original_Pid} == $$; my $hub = $ctx->hub; return if $hub->bailed_out; my $plan = $hub->plan; my $count = $hub->count; my $failed = $hub->failed; my $passed = $hub->is_passing; return unless $plan || $count || $failed; # Ran tests but never declared a plan or hit done_testing if( !defined($hub->plan) and $hub->count ) { $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); if($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } # But if the tests ran, handle exit code. if($failed > 0) { my $exit_code = $failed <= 254 ? $failed : 254; $$new ||= $exit_code; return; } $$new ||= 254; return; } if ($real_exit_code && !$count) { $self->diag("Looks like your test exited with $real_exit_code before it could output anything."); $$new ||= $real_exit_code; return; } return if $plan && "$plan" eq 'SKIP'; if (!$count) { $self->diag('No tests run!'); $$new ||= 255; return; } if ($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } if ($plan eq 'NO PLAN') { $ctx->plan( $count ); $plan = $hub->plan; } # Figure out if we passed or failed and print helpful messages. my $num_extra = $count - $plan; if ($num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $self->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $ctx->diag(<<"FAIL"); All assertions passed, but errors were encountered. FAIL } my $exit_code = 0; if ($failed) { $exit_code = $failed <= 254 ? $failed : 254; } elsif ($num_extra != 0) { $exit_code = 255; } elsif (!$passed) { $exit_code = 255; } $$new ||= $exit_code; return; } # Some things used this even though it was private... I am looking at you # Test::Builder::Prefix... sub _print_comment { my( $self, $fh, @msgs ) = @_; return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Smash args together like print does. # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; # Escape the beginning, _print will take care of the rest. $msg =~ s/^/# /; local( $\, $", $, ) = ( undef, ' ', '' ); print $fh $msg; return 0; } # This is used by Test::SharedFork to turn on IPC after the fact. Not # documenting because I do not want it used. The method name is borrowed from # Test::Builder 2 # Once Test2 stuff goes stable this method will be removed and Test::SharedFork # will be made smarter. sub coordinate_forks { my $self = shift; { local ($@, $!); require Test2::IPC; } Test2::IPC->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_load(); my $ipc = Test2::IPC::apply_ipc($self->{Stack}); $ipc->set_no_fatal(1); Test2::API::test2_no_wait(1); } sub no_log_results { $_[0]->{no_log_results} = 1 } 1; __END__ =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use base 'Test::Builder::Module'; my $CLASS = __PACKAGE__; sub ok { my($test, $name) = @_; my $tb = $CLASS->builder; $tb->ok($test, $name); } =head1 DESCRIPTION L and L have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program C always returns the same Test::Builder object. No matter how many times you call C, you're getting the same object. This is called a singleton. This is done so that multiple modules share such global information as the test counter and where test output is going. If you want a completely new Test::Builder object different from the singleton, use C. =item B my $Test = Test::Builder->create; Ok, so there can be more than one Test::Builder object and this is how you get it. You might use this instead of C if you're testing a Test::Builder based module, but otherwise you probably want C. B: the implementation is not complete. C, for example, is still shared by B Test::Builder objects, even ones created using this method. Also, the method name may change in the future. =item B $builder->subtest($name, \&subtests, @args); See documentation of C in Test::More. C also, and optionally, accepts arguments which will be passed to the subtests reference. =item B diag $builder->name; Returns the name of the current builder. Top level builders default to C<$0> (the name of the executable). Child builders are named via the C method. If no name is supplied, will be named "Child of $parent->name". =item B $Test->reset; Reinitializes the Test::Builder singleton to its original state. Mostly useful for tests run in persistent environments where the same test might be run multiple times in the same process. =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call C, don't call any of the other methods below. =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the number of tests we expect this test to run and prints out the appropriate headers. =item B $Test->no_plan; Declares that this test will run an indeterminate number of tests. =item B $Test->done_testing(); $Test->done_testing($num_tests); Declares that you are done testing, no more tests will be run after this point. If a plan has not yet been output, it will do so. $num_tests is the number of tests you planned to run. If a numbered plan was already declared, and if this contradicts, a failing test will be run to reflect the planning mistake. If C was declared, this will override. If C is called twice, the second call will issue a failing test. If C<$num_tests> is omitted, the number of tests run will be used, like no_plan. C is, in effect, used when you'd want to use C, but safer. You'd use it like so: $Test->ok($a == $b); $Test->done_testing(); Or to plan a variable number of tests: for my $test (@tests) { $Test->ok($test); } $Test->done_testing(scalar @tests); =item B $plan = $Test->has_plan Find out whether a plan has been defined. C<$plan> is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given C<$reason>. Exits immediately with 0. =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This method isn't terribly useful since modules which share the same Test::Builder object might get exported to different packages and only the last one will be honored. =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. They all return true if the test passed, false if the test failed. C<$name> is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if C<$test> is true, fail if $test is false. Just like Test::Simple's C. =item B $Test->is_eq($got, $expected, $name); Like Test::More's C. Checks if C<$got eq $expected>. This is the string version. C only ever matches another C. =item B $Test->is_num($got, $expected, $name); Like Test::More's C. Checks if C<$got == $expected>. This is the numeric version. C only ever matches another C. =item B $Test->isnt_eq($got, $dont_expect, $name); Like L's C. Checks if C<$got ne $dont_expect>. This is the string version. =item B $Test->isnt_num($got, $dont_expect, $name); Like L's C. Checks if C<$got ne $dont_expect>. This is the numeric version. =item B $Test->like($thing, qr/$regex/, $name); $Test->like($thing, '/$regex/', $name); Like L's C. Checks if $thing matches the given C<$regex>. =item B $Test->unlike($thing, qr/$regex/, $name); $Test->unlike($thing, '/$regex/', $name); Like L's C. Checks if $thing B the given C<$regex>. =item B $Test->cmp_ok($thing, $type, $that, $name); Works just like L's C. $Test->cmp_ok($big_num, '!=', $other_big_num); =back =head2 Other Testing Methods These are methods which are used in the course of writing a test but are not themselves tests. =over 4 =item B $Test->BAIL_OUT($reason); Indicates to the L that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =for deprecated BAIL_OUT() used to be BAILOUT() =item B $Test->skip; $Test->skip($why); Skips the current test, reporting C<$why>. =item B $Test->todo_skip; $Test->todo_skip($why); Like C, only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like C, only it skips all the rest of the tests you plan to run and terminates the test. If you're running under C, it skips once and terminates the test. =end _unimplemented =back =head2 Test building utility methods These methods are useful when writing your own test methods. =over 4 =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); This method used to be useful back when Test::Builder worked on Perls before 5.6 which didn't have qr//. Now its pretty useless. Convenience method for building testing functions that take regular expressions as arguments. Takes a quoted regular expression produced by C, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or C if its argument is not recognized. For example, a version of C, sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $thing, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($thing =~ m/$usable_regex/, $name); } =item B my $is_fh = $Test->is_fh($thing); Determines if the given C<$thing> can be used as a filehandle. =cut =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should C<$Test> look when reporting where the test failed. Defaults to 1. Setting C<$Test::Builder::Level> overrides. This is typically useful localized: sub my_ok { my $test = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; $TB->ok($test); } To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Defaults to on. =item B $Test->no_diag($no_diag); If set true no diagnostics will be printed. This includes calls to C. =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described below. If this is true, none of that will be done. =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given C<@msgs>. Like C, arguments are simply appended together. Normally, it uses the C handle, but if this is for a TODO test, the C handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because C is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =item B $Test->note(@msgs); Like C, but it prints to the C handle so it will not normally be seen by the user except in verbose mode. =item B my @dump = $Test->explain(@msgs); Will dump the contents of any references in a human readable format. Handy for things like... is_deeply($have, $want) || diag explain $have; or is_deeply($have, $want) || note explain $have; =item B =item B =item B my $filehandle = $Test->output; $Test->output($filehandle); $Test->output($filename); $Test->output(\$scalar); These methods control where Test::Builder will print its output. They take either an open C<$filehandle>, a C<$filename> to open and write to or a C<$scalar> reference to append to. It will always return a C<$filehandle>. B is where normal "ok/not ok" test output goes. Defaults to STDOUT. B is where diagnostic output on test failures and C goes. It is normally not read by Test::Harness and instead is displayed to the user. Defaults to STDERR. C is used instead of C for the diagnostics of a failing TODO test. These will not be seen by the user. Defaults to STDOUT. =item reset_outputs $tb->reset_outputs; Resets all the output filehandles back to their defaults. =item carp $tb->carp(@message); Warns with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). =item croak $tb->croak(@message); Dies with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). =back =head2 Test Status and Info =over 4 =item B This will turn off result long-term storage. Calling this method will make C
and C useless. You may want to use this if you are running enough tests to fill up all available memory. Test::Builder->new->no_log_results(); There is no way to turn it back on. =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test number we're on. You usually shouldn't have to set this. If set forward, the details of the missing tests are filled in as 'unknown'. if set backward, the details of the intervening tests are deleted. You can erase history if you really want to. =item B my $ok = $builder->is_passing; Indicates if the test suite is currently passing. More formally, it will be false if anything has happened which makes it impossible for the test suite to pass. True otherwise. For example, if no tests have run C will be true because even though a suite with no tests is a failure you can add a passing test to it and start passing. Don't think about it too much. =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =item B
my @tests = $Test->details; Like C, but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when C is changed. In these cases, Test::Builder doesn't know the result of the test, so its type is 'unknown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left C. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since its todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); If the current tests are considered "TODO" it will return the reason, if any. This reason can come from a C<$TODO> variable or the last call to C. Since a TODO test does not need a reason, this function can return an empty string even when inside a TODO block. Use C<< $Test->in_todo >> to determine if you are currently inside a TODO block. C is about finding the right package to look for C<$TODO> in. It's pretty good at guessing the right package to look at. It first looks for the caller based on C<$Level + 1>, since C is usually called inside a test function. As a last resort it will use C. Sometimes there is some confusion about where C should be looking for the C<$TODO> variable. If you want to be sure, tell it explicitly what $pack to use. =item B my $todo_reason = $Test->find_TODO(); my $todo_reason = $Test->find_TODO($pack); Like C but only returns the value of C<$TODO> ignoring C. Can also be used to set C<$TODO> to a new value while returning the old value: my $old_reason = $Test->find_TODO($pack, 1, $new_reason); =item B my $in_todo = $Test->in_todo; Returns true if the test is currently inside a TODO block. =item B $Test->todo_start(); $Test->todo_start($message); This method allows you declare all subsequent tests as TODO tests, up until the C method has been called. The C and C<$TODO> syntax is generally pretty good about figuring out whether or not we're in a TODO test. However, often we find that this is not possible to determine (such as when we want to use C<$TODO> but the tests are being executed in other packages which can't be inferred beforehand). Note that you can use this to nest "todo" tests $Test->todo_start('working on this'); # lots of code $Test->todo_start('working on that'); # more code $Test->todo_end; $Test->todo_end; This is generally not recommended, but large testing systems often have weird internal needs. We've tried to make this also work with the TODO: syntax, but it's not guaranteed and its use is also discouraged: TODO: { local $TODO = 'We have work to do!'; $Test->todo_start('working on this'); # lots of code $Test->todo_start('working on that'); # more code $Test->todo_end; $Test->todo_end; } Pick one style or another of "TODO" to be on the safe side. =item C $Test->todo_end; Stops running tests as "TODO" tests. This method is fatal if called without a preceding C method call. =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal C, except it reports according to your C. C<$height> will be added to the C. If C winds up off the top of the stack it report the highest context. =back =head1 EXIT CODES If all your tests passed, Test::Builder will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Builder will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. =head1 THREADS In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is shared by all threads. This means if one thread sets the test number using C they will all be affected. While versions earlier than 5.8.1 had threads they contain too many bugs to support. Test::Builder is only thread-aware if threads.pm is loaded I Test::Builder. You can directly disable thread support with one of the following: $ENV{T2_NO_IPC} = 1 or no Test2::IPC; or Test2::API::test2_ipc_disable() =head1 MEMORY An informative hash, accessible via C, is stored for each test you perform. So memory usage will scale linearly with each test run. Although this is not a problem for most test suites, it can become an issue if you do large (hundred thousands to million) combinatorics tests in the same run. In such cases, you are advised to either split the test file into smaller ones, or use a reverse approach, doing "normal" (code) compares and triggering C should anything go unexpected. Future versions of Test::Builder will have a way to turn history off. =head1 EXAMPLES CPAN can provide the best examples. L, L, L and L all use Test::Builder. =head1 SEE ALSO =head2 INTERNALS L, L =head2 LEGACY L, L =head2 EXTERNAL L =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2002-2008 by chromatic Echromatic@wgz.orgE and Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L Require.t100644001750001750 151514772042322 20233 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse 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 overridden" ); 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; Compare.t100644001750001750 735114772042322 20211 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse 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; behavior000755001750001750 014772042322 16417 5ustar00exodistexodist000000000000Test-Simple-1.302210/tsimple.t100644001750001750 26314772042322 20216 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::AsyncSubtest; my $ast = async_subtest foo => sub { ok(1, "Simple"); }; $ast->finish; done_testing; spec.t100644001750001750 53514772042322 20150 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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; skip.t100644001750001750 1005514772042322 20222 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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; } } bail_out.t100644001750001750 152314772042322 20150 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } my $Exit_Code; BEGIN { *CORE::GLOBAL::exit = sub { $Exit_Code = shift; }; } # This test uses multiple builders, the real one is using the top hub, we need # to fix the ending. Test2::API::test2_stack()->top->set_no_ending(1); use Test::Builder; use Test::More; my $output; my $TB = Test::More->builder; $TB->output(\$output); my $Test = Test::Builder->create; $Test->level(0); $Test->plan(tests => 3); plan tests => 4; BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); $Test->is_eq( $output, <<'OUT' ); 1..4 Bail out! ROCKS FALL! EVERYONE DIES! OUT $Test->is_eq( $Exit_Code, 255 ); $Test->ok( $Test->can("BAILOUT"), "Backwards compat" ); run_test.t100644001750001750 1020714772042322 20234 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use Test::Tester; use Data::Dumper qw(Dumper); my $test = Test::Builder->new; $test->plan(tests => 54); my $cap; { $cap = Test::Tester->capture; my ($prem, @results) = run_tests( sub {$cap->ok(1, "run pass")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "run pass no prem"); $test->is_num(scalar (@results), 1, "run pass result count"); my $res = $results[0]; $test->is_eq($res->{name}, "run pass", "run pass name"); $test->is_eq($res->{ok}, 1, "run pass ok"); $test->is_eq($res->{actual_ok}, 1, "run pass actual_ok"); $test->is_eq($res->{reason}, "", "run pass reason"); $test->is_eq($res->{type}, "", "run pass type"); $test->is_eq($res->{diag}, "", "run pass diag"); $test->is_num($res->{depth}, 0, "run pass depth"); } { my ($prem, @results) = run_tests( sub {$cap->ok(0, "run fail")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "run fail no prem"); $test->is_num(scalar (@results), 1, "run fail result count"); my $res = $results[0]; $test->is_eq($res->{name}, "run fail", "run fail name"); $test->is_eq($res->{actual_ok}, 0, "run fail actual_ok"); $test->is_eq($res->{ok}, 0, "run fail ok"); $test->is_eq($res->{reason}, "", "run fail reason"); $test->is_eq($res->{type}, "", "run fail type"); $test->is_eq($res->{diag}, "", "run fail diag"); $test->is_num($res->{depth}, 0, "run fail depth"); } { my ($prem, @results) = run_tests( sub {$cap->skip("just because")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "skip no prem"); $test->is_num(scalar (@results), 1, "skip result count"); my $res = $results[0]; $test->is_eq($res->{name}, "", "skip name"); $test->is_eq($res->{actual_ok}, 1, "skip actual_ok"); $test->is_eq($res->{ok}, 1, "skip ok"); $test->is_eq($res->{reason}, "just because", "skip reason"); $test->is_eq($res->{type}, "skip", "skip type"); $test->is_eq($res->{diag}, "", "skip diag"); $test->is_num($res->{depth}, 0, "skip depth"); } { my ($prem, @results) = run_tests( sub {$cap->todo_skip("just because")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "todo_skip no prem"); $test->is_num(scalar (@results), 1, "todo_skip result count"); my $res = $results[0]; $test->is_eq($res->{name}, "", "todo_skip name"); $test->is_eq($res->{actual_ok}, 0, "todo_skip actual_ok"); $test->is_eq($res->{ok}, 1, "todo_skip ok"); $test->is_eq($res->{reason}, "just because", "todo_skip reason"); $test->is_eq($res->{type}, "todo_skip", "todo_skip type"); $test->is_eq($res->{diag}, "", "todo_skip diag"); $test->is_num($res->{depth}, 0, "todo_skip depth"); } { my ($prem, @results) = run_tests( sub {$cap->diag("run diag")} ); local $Test::Builder::Level = 0; $test->is_eq($prem, "run diag\n", "run diag prem"); $test->is_num(scalar (@results), 0, "run diag result count"); } { my ($prem, @results) = run_tests( sub { $cap->ok(1, "multi pass"); $cap->diag("multi pass diag1"); $cap->diag("multi pass diag2"); $cap->ok(0, "multi fail"); $cap->diag("multi fail diag"); } ); local $Test::Builder::Level = 0; $test->is_eq($prem, "", "run multi no prem"); $test->is_num(scalar (@results), 2, "run multi result count"); my $res_pass = $results[0]; $test->is_eq($res_pass->{name}, "multi pass", "run multi pass name"); $test->is_eq($res_pass->{actual_ok}, 1, "run multi pass actual_ok"); $test->is_eq($res_pass->{ok}, 1, "run multi pass ok"); $test->is_eq($res_pass->{reason}, "", "run multi pass reason"); $test->is_eq($res_pass->{type}, "", "run multi pass type"); $test->is_eq($res_pass->{diag}, "multi pass diag1\nmulti pass diag2\n", "run multi pass diag"); $test->is_num($res_pass->{depth}, 0, "run multi pass depth"); my $res_fail = $results[1]; $test->is_eq($res_fail->{name}, "multi fail", "run multi fail name"); $test->is_eq($res_pass->{actual_ok}, 1, "run multi fail actual_ok"); $test->is_eq($res_fail->{ok}, 0, "run multi fail ok"); $test->is_eq($res_pass->{reason}, "", "run multi fail reason"); $test->is_eq($res_pass->{type}, "", "run multi fail type"); $test->is_eq($res_fail->{diag}, "multi fail diag\n", "run multi fail diag"); $test->is_num($res_pass->{depth}, 0, "run multi fail depth"); } versions.t100644001750001750 76714772042322 20213 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # HARNESS-NO-PRELOAD # Make sure all the modules have the same version # # TBT has its own version system. use strict; use Test::More; require Test::Builder; require Test::Builder::Module; require Test::Simple; my $dist_version = Test::More->VERSION; like( $dist_version, qr/^ \d+ \. \d+ $/x ); my @modules = qw( Test::Simple Test::Builder Test::Builder::Module ); for my $module (@modules) { is( $dist_version, $module->VERSION, $module ); } done_testing(4); overload.t100644001750001750 420514772042322 20165 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 19; package Overloaded; use overload q{eq} => sub { $_[0]->{string} eq $_[1] }, q{==} => sub { $_[0]->{num} == $_[1] }, q{""} => sub { $_[0]->{stringify}++; $_[0]->{string} }, q{0+} => sub { $_[0]->{numify}++; $_[0]->{num} } ; sub new { my $class = shift; bless { string => shift, num => shift, stringify => 0, numify => 0, }, $class; } package main; local $SIG{__DIE__} = sub { my($call_file, $call_line) = (caller)[1,2]; fail("SIGDIE accidentally called"); diag("From $call_file at $call_line"); }; my $obj = Overloaded->new('foo', 42); isa_ok $obj, 'Overloaded'; cmp_ok $obj, 'eq', 'foo', 'cmp_ok() eq'; is $obj->{stringify}, 0, ' does not stringify'; is $obj, 'foo', 'is() with string overloading'; cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading'; is $obj->{numify}, 0, ' does not numify'; is_deeply [$obj], ['foo'], 'is_deeply with string overloading'; ok eq_array([$obj], ['foo']), 'eq_array ...'; ok eq_hash({foo => $obj}, {foo => 'foo'}), 'eq_hash ...'; # rt.cpan.org 13506 is_deeply $obj, 'foo', 'is_deeply with string overloading at the top'; Test::More->builder->is_num($obj, 42); Test::More->builder->is_eq ($obj, "foo"); { # rt.cpan.org 14675 package TestPackage; use overload q{""} => sub { ::fail("This should not be called") }; package Foo; ::is_deeply(['TestPackage'], ['TestPackage']); ::is_deeply({'TestPackage' => 'TestPackage'}, {'TestPackage' => 'TestPackage'}); ::is_deeply('TestPackage', 'TestPackage'); } # Make sure 0 isn't a special case. [rt.cpan.org 41109] { my $obj = Overloaded->new('0', 42); isa_ok $obj, 'Overloaded'; cmp_ok $obj, 'eq', '0', 'cmp_ok() eq'; is $obj->{stringify}, 0, ' does not stringify'; is $obj, '0', 'is() with string overloading'; } no_tests.t100644001750001750 146714772042322 20217 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 3); package main; require Test::Simple; chdir 't'; push @INC, '../t/lib/'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; Test::Simple->import(tests => 1); END { $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 255, "exit code"); $? = grep { !$_ } $TB->summary; } fail_one.t100644001750001750 155114772042322 20127 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; # Normalize the output whether we're running under Test::Harness or not. local $ENV{HARNESS_ACTIVE} = 0; use Test::Builder; use Test::Builder::NoOutput; # TB methods expect to be wrapped my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $done_testing = sub { shift->done_testing(@_) }; my $Test = Test::Builder->new; { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 1 ); #line 28 $tb->$ok(0); $tb->_ending; $Test->is_eq($tb->read('out'), <is_eq($tb->read('err'), <$done_testing(2); } 01-basic.t100644001750001750 13214772042322 17624 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use Test::More tests => 3; use ok 'strict'; use ok 'Test::More'; use ok 'ok'; bad_plan.t100644001750001750 75714772042322 20102 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::Builder; my $Test = Test::Builder->new; $Test->plan( tests => 2 ); $Test->level(0); my $tb = Test::Builder->create; eval { $tb->plan(7); }; $Test->like( $@, qr/^plan\(\) doesn't understand 7/, 'bad plan()' ) || print STDERR "# $@"; eval { $tb->plan(wibble => 7); }; $Test->like( $@, qr/^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) || print STDERR "# $@"; plan_bad.t100644001750001750 206014772042322 20107 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 12; use Test::Builder; my $tb = Test::Builder->create; $tb->level(0); ok !eval { $tb->plan( tests => 'no_plan' ); }; is $@, sprintf "Number of tests must be a positive integer. You gave it 'no_plan' at %s line %d.\n", $0, __LINE__ - 1; my $foo = []; my @foo = ($foo, 2, 3); ok !eval { $tb->plan( tests => @foo ) }; is $@, sprintf "Number of tests must be a positive integer. You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1; ok !eval { $tb->plan( tests => 9.99 ) }; is $@, sprintf "Number of tests must be a positive integer. You gave it '9.99' at %s line %d.\n", $0, __LINE__ - 1; #line 25 ok !eval { $tb->plan( tests => -1 ) }; is $@, "Number of tests must be a positive integer. You gave it '-1' at $0 line 25.\n"; #line 29 ok !eval { $tb->plan( tests => '' ) }; is $@, "You said to run 0 tests at $0 line 29.\n"; #line 33 ok !eval { $tb->plan( 'wibble' ) }; is $@, "plan() doesn't understand wibble at $0 line 33.\n"; Bugs000755001750001750 014772042322 16724 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy629.t100644001750001750 170314772042322 17572 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Bugsuse strict; use warnings; use Test::More; use Test2::API qw/intercept/; my @warnings; intercept { SKIP: { local $SIG{__WARN__} = sub { @warnings = @_ }; skip 'Skipping this test' if 1; my $var = 'abc'; is $var, 'abc'; } }; ok(!@warnings, "did not warn when waiting for done_testing"); intercept { SKIP: { local $SIG{__WARN__} = sub { @warnings = @_ }; plan 'no_plan'; skip 'Skipping this test' if 1; my $var = 'abc'; is $var, 'abc'; } }; ok(!@warnings, "did not warn with 'no_plan'"); intercept { SKIP: { local $SIG{__WARN__} = sub { @warnings = @_ }; plan tests => 1; skip 'Skipping this test' if 1; my $var = 'abc'; is $var, 'abc'; } }; is(@warnings, 1, "warned with static plan"); like( $warnings[0], qr/skip\(\) needs to know \$how_many tests are in the block/, "Got expected warning" ); done_testing; 600.t100644001750001750 55414772042322 17542 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Bugsuse Test2::API qw/intercept/; use Test::More; my $TEST = Test::Builder->new(); sub fake { $TEST->use_numbers(0); $TEST->no_ending(1); $TEST->done_testing(1); # a computed number of tests from its deferred magic } my $events = intercept { fake() }; is(@$events, 1, "only 1 event"); is($events->[0]->max, 1, "Plan set to 1, not 0"); done_testing; MyOverload.pm100644001750001750 153214772042322 20146 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libpackage Overloaded; ##no critic (Modules::RequireFilenameMatchesPackage) use strict; sub new { my $class = shift; bless { string => shift, num => shift }, $class; } package Overloaded::Compare; use strict; our @ISA = qw(Overloaded); # Sometimes objects have only comparison ops overloaded and nothing else. # For example, DateTime objects. use overload q{eq} => sub { $_[0]->{string} eq $_[1] }, q{==} => sub { $_[0]->{num} == $_[1] }; package Overloaded::Ify; use strict; our @ISA = qw(Overloaded); use overload q{""} => sub { @_ == 3 or die "Expected 3 parameters"; $_[0]->{string}; }, q{0+} => sub { @_ == 3 or die "Expected 3 parameters"; $_[0]->{num}; }; package Overloaded::Partial; our @ISA = qw(Overloaded); use overload q{""} => sub { $_[0]->{string} }, q{!=} => sub { $_[0]->{num} != $_[1] }; 1; NoExporter.pm100644001750001750 22614772042322 20151 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/libpackage NoExporter; use strict; our $VERSION = 1.02; sub import { shift; die "NoExporter exports nothing. You asked for: @_" if @_; } 1; Require.pm100644001750001750 522414772042322 20241 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Require; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Compare.pm100644001750001750 2703114772042322 20233 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Compare; use strict; use warnings; our $VERSION = '1.302210'; 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 affects 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 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 zzz-check-breaks.t100644001750001750 376514772042322 20335 0ustar00exodistexodist000000000000Test-Simple-1.302210/tuse strict; use warnings; # Must not fail! END { $? = 0 } # this test is very similar to what is generated by Dist::Zilla::Plugin::Test::CheckBreaks use Test::More; eval { require CPAN::Meta; require CPAN::Meta::Requirements; CPAN::Meta::Requirements->VERSION(2.120920); require Module::Metadata; 1 } or plan skip_all => 'breakage test requires CPAN::Meta, CPAN::Meta::Requirements and Module::Metadata'; my $metafile = -e 'MYMETA.json' ? 'MYMETA.json' : -e 'META.json' ? 'META.json' : undef; unless ($metafile) { plan skip_all => "can't check breakages without some META file"; } eval { my $breaks = CPAN::Meta->load_file($metafile)->custom('x_breaks'); my $reqs = CPAN::Meta::Requirements->new; $reqs->add_string_requirement($_, $breaks->{$_}) foreach keys %$breaks; my $result = check_breaks($reqs); if (my @breaks = grep { defined $result->{$_} } keys %$result) { diag 'You have the following modules installed, which are not compatible with the latest Test::More:'; diag "$result->{$_}" for sort @breaks; diag "\n", 'You should now update these modules!'; diag "You should also see Test2::Transition!"; } pass 'conflicting modules checked'; 1; } or plan skip_all => "Could not check conflicting modules: $@"; # this is an inlined simplification of CPAN::Meta::Check. sub check_breaks { my $reqs = shift; return +{ map { $_ => _check_break($reqs, $_) } $reqs->required_modules, }; } sub _check_break { my ($reqs, $module) = @_; my $metadata = Module::Metadata->new_from_module($module); return undef if not defined $metadata; my $version = eval { $metadata->version }; return "Missing version info for module '$module'" if not $version; return sprintf 'Installed version (%s) of %s is in range \'%s\'', $version, $module, $reqs->requirements_for_module($module) if $reqs->accepts_module($module, $version); return undef; } done_testing; Workflow.t100644001750001750 13514772042322 20406 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse Test2::Bundle::Extended -target => 'Test2::Workflow'; skip_all "Tests not yet written"; Util000755001750001750 014772042322 17205 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesRef.t100644001750001750 204514772042322 20247 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Utiluse 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; Sub.t100644001750001750 120114772042322 20255 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Utiluse 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; Mocking.t100644001750001750 242314772042322 20334 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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; Tools.t100644001750001750 165414772042322 20341 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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; extra_one.t100644001750001750 161614772042322 20341 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 2); sub is { $TB->is_eq(@_) } package main; require Test::Simple; Test::Simple->import(tests => 1); ok(1); ok(1); ok(1); END { My::Test::is($$out, <create; $TB->plan(tests => 81); sub like ($$;$) { $TB->like(@_); } sub is ($$;$) { $TB->is_eq(@_); } sub main::out_ok ($$) { $TB->is_eq( $out->read, shift ); $TB->is_eq( $err->read, shift ); } sub main::out_warn_ok ($$$) { $TB->is_eq( $out->read, shift ); $TB->is_eq( $err->read, shift ); my $warning_expected = shift; $warning_expected =~ s/^# //mg; $TB->is_eq( $main::warning, $warning_expected ); } sub main::out_like ($$) { my($output, $failure) = @_; $TB->like( $out->read, qr/$output/ ); $TB->like( $err->read, qr/$failure/ ); } package main; require Test::More; our $TODO; my $Total = 38; Test::More->import(tests => $Total); $out->read; # clear the plan from $out # This should all work in the presence of a __DIE__ handler. local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); }; local $SIG{__WARN__} = sub { $main::warning = $_[0]; }; my $tb = Test::More->builder; $tb->use_numbers(0); my $Filename = quotemeta $0; #line 38 ok( 0, 'failing' ); out_ok( <can(...) OUT # Failed test 'Mooble::Hooble::Yooble->can(...)' # at $0 line 197. # Mooble::Hooble::Yooble->can('this') failed # Mooble::Hooble::Yooble->can('that') failed ERR #line 208 can_ok('Mooble::Hooble::Yooble', ()); out_ok( <can(...) OUT # Failed test 'Mooble::Hooble::Yooble->can(...)' # at $0 line 208. # can_ok() called with no methods ERR #line 218 can_ok(undef, undef); out_ok( <can(...) OUT # Failed test '->can(...)' # at $0 line 218. # can_ok() called with empty class or reference ERR #line 228 can_ok([], "foo"); out_ok( <can('foo') OUT # Failed test 'ARRAY->can('foo')' # at $0 line 228. # ARRAY->can('foo') failed ERR #line 238 isa_ok(bless([], "Foo"), "Wibble"); out_ok( <new\\(\\) died OUT # Failed test 'undef->new\\(\\) died' # at $Filename line 278. # Error was: Can't call method "new" on an undefined value at .* ERR #line 288 new_ok( "Does::Not::Exist" ); out_like( <new\\(\\) died OUT # Failed test 'Does::Not::Exist->new\\(\\) died' # at $Filename line 288. # Error was: Can't locate object method "new" via package "Does::Not::Exist" .* ERR { package Foo; sub new { } } { package Bar; sub new { {} } } { package Baz; sub new { bless {}, "Wibble" } } #line 303 new_ok( "Foo" ); out_ok( <is_eq( $out->read, <is_eq( $err->read, <create; $TB->plan(tests => 4); require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; package main; require Test::More; Test::More->import(tests => 1); { eval q{ like( "foo", qr/that/, 'is foo like that' ); }; $TB->is_eq($out->read, <like($err->read, qr/^$err_re$/, 'failing errors'); } { # line 63 like("foo", "not a regex"); $TB->is_eq($out->read, <is_eq($err->read, <summary; } legacy000755001750001750 014772042322 17065 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2TAP.t100644001750001750 463114772042322 20042 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/legacyuse strict; use warnings; # HARNESS-NO-FORMATTER use Test2::Tools::Tiny; ######################### # # This test us here to insure that Ok, Diag, and Note events render the way # Test::More renders them, trailing whitespace and all. # ######################### use Test2::API qw/test2_stack context/; # The tools in Test2::Tools::Tiny have some intentional differences from the # Test::More versions, these behave more like Test::More which is important for # back-compat. sub tm_ok($;$) { my ($bool, $name) = @_; my $ctx = context; my $ok = bless { pass => $bool, name => $name, effective_pass => 1, trace => $ctx->trace->snapshot, }, 'Test2::Event::Ok'; # Do not call init $ctx->hub->send($ok); $ctx->release; return $bool; } # Test::More actually does a bit more, but for this test we just want to see # what happens when message is a specific string, or undef. sub tm_diag { my $ctx = context(); $ctx->diag(@_); $ctx->release; } sub tm_note { my $ctx = context(); $ctx->note(@_); $ctx->release; } # Ensure the top hub is generated test2_stack->top; my $temp_hub = test2_stack->new_hub(); require Test::Builder::Formatter; $temp_hub->format(Test::Builder::Formatter->new); my $diag = capture { tm_diag(undef); tm_diag(""); tm_diag(" "); tm_diag("A"); tm_diag("\n"); tm_diag("\nB"); tm_diag("C\n"); tm_diag("\nD\n"); tm_diag("E\n\n"); }; my $note = capture { tm_note(undef); tm_note(""); tm_note(" "); tm_note("A"); tm_note("\n"); tm_note("\nB"); tm_note("C\n"); tm_note("\nD\n"); tm_note("E\n\n"); }; my $ok = capture { tm_ok(1); tm_ok(1, ""); tm_ok(1, " "); tm_ok(1, "A"); tm_ok(1, "\n"); tm_ok(1, "\nB"); tm_ok(1, "C\n"); tm_ok(1, "\nD\n"); tm_ok(1, "E\n\n"); }; test2_stack->pop($temp_hub); is($diag->{STDOUT}, "", "STDOUT is empty for diag"); is($diag->{STDERR}, <{STDERR}, "", "STDERR for note is empty"); is($note->{STDOUT}, <{STDERR}, "", "STDERR for ok is empty"); is($ok->{STDOUT}, <[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 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 Event000755001750001750 014772042322 17205 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Ok.pm100644001750001750 613114772042322 20255 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Ok; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{ pass effective_pass name todo }; sub init { my $self = shift; # Do not store objects here, only true or false $self->{+PASS} = $self->{+PASS} ? 1 : 0; $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0); } { no warnings 'redefine'; sub set_todo { my $self = shift; my ($todo) = @_; $self->{+TODO} = $todo; $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS}; } } sub increments_count { 1 }; sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} } sub summary { my $self = shift; my $name = $self->{+NAME} || "Nameless Assertion"; my $todo = $self->{+TODO}; if ($todo) { $name .= " (TODO: $todo)"; } elsif (defined $todo) { $name .= " (TODO)" } return $name; } sub extra_amnesty { my $self = shift; return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS}); return { tag => 'TODO', details => $self->{+TODO}, }; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{assert} = { no_debug => 1, # Legacy behavior pass => $self->{+PASS}, details => $self->{+NAME}, }; if (my @extra_amnesty = $self->extra_amnesty) { my %seen; # It is possible the extra amnesty can be a duplicate, so filter it. $out->{amnesty} = [ grep { !$seen{defined($_->{tag}) ? $_->{tag} : ''}->{defined($_->{details}) ? $_->{details} : ''}++ } @extra_amnesty, @{$out->{amnesty}}, ]; } return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Ok - Ok event type =head1 DESCRIPTION Ok events are generated whenever you run a test that produces a result. Examples are C, and C. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Ok; my $ctx = context(); my $event = $ctx->ok($bool, $name, \@diag); or: my $ctx = context(); my $event = $ctx->send_event( 'Ok', pass => $bool, name => $name, ); =head1 ACCESSORS =over 4 =item $rb = $e->pass The original true/false value of whatever was passed into the event (but reduced down to 1 or 0). =item $name = $e->name Name of the test. =item $b = $e->effective_pass This is the true/false value of the test after TODO and similar modifiers are taken into account. =back =head1 SOURCE The source code repository for Test2 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 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 V2.pm100644001750001750 1145014772042322 20213 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::V2; use strict; use warnings; our $VERSION = '1.302210'; use Scalar::Util qw/reftype/; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::Facets2Legacy qw{ causes_fail diagnostics global increments_count no_display sets_plan subtest_id summary terminate }; use Test2::Util::HashBase qw/-about/; sub non_facet_keys { return ( +UUID, Test2::Util::ExternalMeta::META_KEY(), ); } sub init { my $self = shift; my $uuid; if ($uuid = $self->{+UUID}) { croak "uuid '$uuid' passed to constructor, but uuid '$self->{+ABOUT}->{uuid}' is already set in the 'about' facet" if $self->{+ABOUT}->{uuid} && $self->{+ABOUT}->{uuid} ne $uuid; $self->{+ABOUT}->{uuid} = $uuid; } elsif ($self->{+ABOUT} && $self->{+ABOUT}->{uuid}) { $uuid = $self->{+ABOUT}->{uuid}; $self->SUPER::set_uuid($uuid); } # Clone the trace, make sure it is blessed if (my $trace = $self->{+TRACE}) { $self->{+TRACE} = Test2::EventFacet::Trace->new(%$trace); } } sub set_uuid { my $self = shift; my ($uuid) = @_; $self->{+ABOUT}->{uuid} = $uuid; $self->SUPER::set_uuid($uuid); } sub facet_data { my $self = shift; my $f = { %{$self} }; delete $f->{$_} for $self->non_facet_keys; my %out; for my $k (keys %$f) { next if substr($k, 0, 1) eq '_'; my $data = $f->{$k} or next; # Key is there, but no facet my $is_list = 'ARRAY' eq (reftype($data) || ''); $out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data}; } if (my $meta = $self->meta_facet_data) { $out{meta} = {%$meta, %{$out{meta} || {}}}; } return \%out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::V2 - Second generation event. =head1 DESCRIPTION This is the event type that should be used instead of L or its legacy subclasses. =head1 SYNOPSIS =head2 USING A CONTEXT use Test2::API qw/context/; sub my_tool { my $ctx = context(); my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]); $ctx->release; return $event; } =head2 USING THE CONSTRUCTOR use Test2::Event::V2; my $e = Test2::Event::V2->new( trace => {frame => [$PKG, $FILE, $LINE, $SUBNAME]}, info => [{tag => 'NOTE', details => "This is a note"}], ); =head1 METHODS This class inherits from L. =over 4 =item $fd = $e->facet_data() This will return a hashref of facet data. Each facet hash will be a shallow copy of the original. =item $about = $e->about() This will return the 'about' facet hashref. B This will return the internal hashref, not a copy. =item $trace = $e->trace() This will return the 'trace' facet, normally blessed (but this is not enforced when the trace is set using C. B This will return the internal trace, not a copy. =back =head2 MUTATION =over 4 =item $e->add_amnesty({...}) Inherited from L. This can be used to add 'amnesty' facets to an existing event. Each new item is added to the B of the list. B Items B blessed when added. =item $e->add_hub({...}) Inherited from L. This is used by hubs to stamp events as they pass through. New items are added to the B of the list. B Items B blessed when added. =item $e->set_uuid($UUID) Inherited from L, overridden to also vivify/mutate the 'about' facet. =item $e->set_trace($trace) Inherited from L which allows you to change the trace. B This method does not bless/clone the trace for you. Many things will expect the trace to be blessed, so you should probably do that. =back =head2 LEGACY SUPPORT METHODS These are all imported from L, see that module or L for documentation on what they do. =over 4 =item causes_fail =item diagnostics =item global =item increments_count =item no_display =item sets_plan =item subtest_id =item summary =item terminate =back =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at 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 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 Util000755001750001750 014772042322 17041 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Sig.pm100644001750001750 423314772042322 20263 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Sig; use strict; use warnings; our $VERSION = '1.302210'; use POSIX(); use Test2::Util qw/try IS_WIN32/; our @EXPORT_OK = qw{ try_sig_mask }; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub try_sig_mask(&) { my $code = shift; my ($old, $blocked); unless(IS_WIN32) { my $to_block = POSIX::SigSet->new( POSIX::SIGINT(), POSIX::SIGALRM(), POSIX::SIGHUP(), POSIX::SIGTERM(), POSIX::SIGUSR1(), POSIX::SIGUSR2(), ); $old = POSIX::SigSet->new; $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); # Silently go on if we failed to log signals, not much we can do. } my ($ok, $err) = &try($code); # If our block was successful we want to restore the old mask. POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; return ($ok, $err); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Sig - Signal tools used by Test2 and friends. =head1 DESCRIPTION Collection of signal tools used by L and friends. =head1 EXPORTS All exports are optional. You must specify subs to import. =over 4 =item ($ok, $err) = try_sig_mask { ... } Complete an action with several signals masked, they will be unmasked at the end allowing any signals that were intercepted to get handled. This is primarily used when you need to make several actions atomic (against some signals anyway). Signals that are intercepted: =over 4 =item SIGINT =item SIGALRM =item SIGHUP =item SIGTERM =item SIGUSR1 =item SIGUSR2 =back =back =head1 SOURCE The source code repository for Test2 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 =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 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 Sub.pm100644001750001750 1124714772042322 20315 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Sub; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Ref.pm100644001750001750 446714772042322 20266 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Ref; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Tutorial.pod100644001750001750 4562214772042322 20542 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test=head1 NAME Test::Tutorial - A tutorial about writing really basic tests =head1 DESCRIPTION I I<*sob*> I Is this you? Is writing tests right up there with writing documentation and having your fingernails pulled out? Did you open up a test and read ######## We start with some black magic and decide that's quite enough for you? It's ok. That's all gone now. We've done all the black magic for you. And here are the tricks... =head2 Nuts and bolts of testing. Here's the most basic test program. #!/usr/bin/perl -w print "1..1\n"; print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n"; Because 1 + 1 is 2, it prints: 1..1 ok 1 What this says is: C<1..1> "I'm going to run one test." [1] C "The first test passed". And that's about all magic there is to testing. Your basic unit of testing is the I. For each thing you test, an C is printed. Simple. L interprets your test results to determine if you succeeded or failed (more on that later). Writing all these print statements rapidly gets tedious. Fortunately, there's L. It has one function, C. #!/usr/bin/perl -w use Test::Simple tests => 1; ok( 1 + 1 == 2 ); That does the same thing as the previous code. C is the backbone of Perl testing, and we'll be using it instead of roll-your-own from here on. If C gets a true value, the test passes. False, it fails. #!/usr/bin/perl -w use Test::Simple tests => 2; ok( 1 + 1 == 2 ); ok( 2 + 2 == 5 ); From that comes: 1..2 ok 1 not ok 2 # Failed test (test.pl at line 5) # Looks like you failed 1 tests of 2. C<1..2> "I'm going to run two tests." This number is a I. It helps to ensure your test program ran all the way through and didn't die or skip some tests. C "The first test passed." C "The second test failed". Test::Simple helpfully prints out some extra commentary about your tests. It's not scary. Come, hold my hand. We're going to give an example of testing a module. For our example, we'll be testing a date library, L. It's on CPAN, so download a copy and follow along. [2] =head2 Where to start? This is the hardest part of testing, where do you start? People often get overwhelmed at the apparent enormity of the task of testing a whole module. The best place to start is at the beginning. L is an object-oriented module, and that means you start by making an object. Test C. #!/usr/bin/perl -w # assume these two lines are in all subsequent examples use strict; use warnings; use Test::Simple tests => 2; use Date::ICal; my $ical = Date::ICal->new; # create an object ok( defined $ical ); # check that we got something ok( $ical->isa('Date::ICal') ); # and it's the right class Run that and you should get: 1..2 ok 1 ok 2 Congratulations! You've written your first useful test. =head2 Names That output isn't terribly descriptive, is it? When you have two tests you can figure out which one is #2, but what if you have 102 tests? Each test can be given a little descriptive name as the second argument to C. use Test::Simple tests => 2; ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); Now you'll see: 1..2 ok 1 - new() returned something ok 2 - and it's the right class =head2 Test the manual The simplest way to build up a decent testing suite is to just test what the manual says it does. [3] Let's pull something out of the L and test that all its bits work. #!/usr/bin/perl -w use Test::Simple tests => 8; use Date::ICal; $ical = Date::ICal->new( year => 1964, month => 10, day => 16, hour => 16, min => 12, sec => 47, tz => '0530' ); ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); ok( $ical->sec == 47, ' sec()' ); ok( $ical->min == 12, ' min()' ); ok( $ical->hour == 16, ' hour()' ); ok( $ical->day == 17, ' day()' ); ok( $ical->month == 10, ' month()' ); ok( $ical->year == 1964, ' year()' ); Run that and you get: 1..8 ok 1 - new() returned something ok 2 - and it's the right class ok 3 - sec() ok 4 - min() ok 5 - hour() not ok 6 - day() # Failed test (- at line 16) ok 7 - month() ok 8 - year() # Looks like you failed 1 tests of 8. Whoops, a failure! [4] L helpfully lets us know on what line the failure occurred, but not much else. We were supposed to get 17, but we didn't. What did we get?? Dunno. You could re-run the test in the debugger or throw in some print statements to find out. Instead, switch from L to L. L does everything L does, and more! In fact, L does things I the way L does. You can literally swap L out and put L in its place. That's just what we're going to do. L does more than L. The most important difference at this point is it provides more informative ways to say "ok". Although you can write almost any test with a generic C, it can't tell you what went wrong. The C function lets us declare that something is supposed to be the same as something else: use Test::More tests => 8; use Date::ICal; $ical = Date::ICal->new( year => 1964, month => 10, day => 16, hour => 16, min => 12, sec => 47, tz => '0530' ); ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); is( $ical->sec, 47, ' sec()' ); is( $ical->min, 12, ' min()' ); is( $ical->hour, 16, ' hour()' ); is( $ical->day, 17, ' day()' ); is( $ical->month, 10, ' month()' ); is( $ical->year, 1964, ' year()' ); "Is C<< $ical->sec >> 47?" "Is C<< $ical->min >> 12?" With C in place, you get more information: 1..8 ok 1 - new() returned something ok 2 - and it's the right class ok 3 - sec() ok 4 - min() ok 5 - hour() not ok 6 - day() # Failed test (- at line 16) # got: '16' # expected: '17' ok 7 - month() ok 8 - year() # Looks like you failed 1 tests of 8. Aha. C<< $ical->day >> returned 16, but we expected 17. A quick check shows that the code is working fine, we made a mistake when writing the tests. Change it to: is( $ical->day, 16, ' day()' ); ... and everything works. Any time you're doing a "this equals that" sort of test, use C. It even works on arrays. The test is always in scalar context, so you can test how many elements are in an array this way. [5] is( @foo, 5, 'foo has 5 elements' ); =head2 Sometimes the tests are wrong This brings up a very important lesson. Code has bugs. Tests are code. Ergo, tests have bugs. A failing test could mean a bug in the code, but don't discount the possibility that the test is wrong. On the flip side, don't be tempted to prematurely declare a test incorrect just because you're having trouble finding the bug. Invalidating a test isn't something to be taken lightly, and don't use it as a cop out to avoid work. =head2 Testing lots of values We're going to be wanting to test a lot of dates here, trying to trick the code with lots of different edge cases. Does it work before 1970? After 2038? Before 1904? Do years after 10,000 give it trouble? Does it get leap years right? We could keep repeating the code above, or we could set up a little try/expect loop. use Test::More tests => 32; use Date::ICal; my %ICal_Dates = ( # An ICal string And the year, month, day # hour, minute and second we expect. '19971024T120000' => # from the docs. [ 1997, 10, 24, 12, 0, 0 ], '20390123T232832' => # after the Unix epoch [ 2039, 1, 23, 23, 28, 32 ], '19671225T000000' => # before the Unix epoch [ 1967, 12, 25, 0, 0, 0 ], '18990505T232323' => # before the MacOS epoch [ 1899, 5, 5, 23, 23, 23 ], ); while( my($ical_str, $expect) = each %ICal_Dates ) { my $ical = Date::ICal->new( ical => $ical_str ); ok( defined $ical, "new(ical => '$ical_str')" ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); is( $ical->year, $expect->[0], ' year()' ); is( $ical->month, $expect->[1], ' month()' ); is( $ical->day, $expect->[2], ' day()' ); is( $ical->hour, $expect->[3], ' hour()' ); is( $ical->min, $expect->[4], ' min()' ); is( $ical->sec, $expect->[5], ' sec()' ); } Now we can test bunches of dates by just adding them to C<%ICal_Dates>. Now that it's less work to test with more dates, you'll be inclined to just throw more in as you think of them. Only problem is, every time we add to that we have to keep adjusting the C<< use Test::More tests => ## >> line. That can rapidly get annoying. There are ways to make this work better. First, we can calculate the plan dynamically using the C function. use Test::More; use Date::ICal; my %ICal_Dates = ( ...same as before... ); # For each key in the hash we're running 8 tests. plan tests => keys(%ICal_Dates) * 8; ...and then your tests... To be even more flexible, use C. This means we're just running some tests, don't know how many. [6] use Test::More; # instead of tests => 32 ... # tests here done_testing(); # reached the end safely If you don't specify a plan, L expects to see C before your program exits. It will warn you if you forget it. You can give C an optional number of tests you expected to run, and if the number ran differs, L will give you another kind of warning. =head2 Informative names Take a look at the line: ok( defined $ical, "new(ical => '$ical_str')" ); We've added more detail about what we're testing and the ICal string itself we're trying out to the name. So you get results like: ok 25 - new(ical => '19971024T120000') ok 26 - and it's the right class ok 27 - year() ok 28 - month() ok 29 - day() ok 30 - hour() ok 31 - min() ok 32 - sec() If something in there fails, you'll know which one it was and that will make tracking down the problem easier. Try to put a bit of debugging information into the test names. Describe what the tests test, to make debugging a failed test easier for you or for the next person who runs your test. =head2 Skipping tests Poking around in the existing L tests, I found this in F [7] #!/usr/bin/perl -w use Test::More tests => 7; use Date::ICal; # Make sure epoch time is being handled sanely. my $t1 = Date::ICal->new( epoch => 0 ); is( $t1->epoch, 0, "Epoch time of 0" ); # XXX This will only work on unix systems. is( $t1->ical, '19700101Z', " epoch to ical" ); is( $t1->year, 1970, " year()" ); is( $t1->month, 1, " month()" ); is( $t1->day, 1, " day()" ); # like the tests above, but starting with ical instead of epoch my $t2 = Date::ICal->new( ical => '19700101Z' ); is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); is( $t2->epoch, 0, " and back to ICal" ); The beginning of the epoch is different on most non-Unix operating systems [8]. Even though Perl smooths out the differences for the most part, certain ports do it differently. MacPerl is one off the top of my head. [9] Rather than putting a comment in the test and hoping someone will read the test while debugging the failure, we can explicitly say it's never going to work and skip the test. use Test::More tests => 7; use Date::ICal; # Make sure epoch time is being handled sanely. my $t1 = Date::ICal->new( epoch => 0 ); is( $t1->epoch, 0, "Epoch time of 0" ); SKIP: { skip('epoch to ICal not working on Mac OS', 6) if $^O eq 'MacOS'; is( $t1->ical, '19700101Z', " epoch to ical" ); is( $t1->year, 1970, " year()" ); is( $t1->month, 1, " month()" ); is( $t1->day, 1, " day()" ); # like the tests above, but starting with ical instead of epoch my $t2 = Date::ICal->new( ical => '19700101Z' ); is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); is( $t2->epoch, 0, " and back to ICal" ); } A little bit of magic happens here. When running on anything but MacOS, all the tests run normally. But when on MacOS, C causes the entire contents of the SKIP block to be jumped over. It never runs. Instead, C prints special output that tells L that the tests have been skipped. 1..7 ok 1 - Epoch time of 0 ok 2 # skip epoch to ICal not working on MacOS ok 3 # skip epoch to ICal not working on MacOS ok 4 # skip epoch to ICal not working on MacOS ok 5 # skip epoch to ICal not working on MacOS ok 6 # skip epoch to ICal not working on MacOS ok 7 # skip epoch to ICal not working on MacOS This means your tests won't fail on MacOS. This means fewer emails from MacPerl users telling you about failing tests that you know will never work. You've got to be careful with skip tests. These are for tests which don't work and I. It is not for skipping genuine bugs (we'll get to that in a moment). The tests are wholly and completely skipped. [10] This will work. SKIP: { skip("I don't wanna die!"); die, die, die, die, die; } =head2 Todo tests While thumbing through the L man page, I came across this: ical $ical_string = $ical->ical; Retrieves, or sets, the date on the object, using any valid ICal date/time string. "Retrieves or sets". Hmmm. I didn't see a test for using C to set the date in the Date::ICal test suite. So I wrote one: use Test::More tests => 1; use Date::ICal; my $ical = Date::ICal->new; $ical->ical('20201231Z'); is( $ical->ical, '20201231Z', 'Setting via ical()' ); Run that. I saw: 1..1 not ok 1 - Setting via ical() # Failed test (- at line 6) # got: '20010814T233649Z' # expected: '20201231Z' # Looks like you failed 1 tests of 1. Whoops! Looks like it's unimplemented. Assume you don't have the time to fix this. [11] Normally, you'd just comment out the test and put a note in a todo list somewhere. Instead, explicitly state "this test will fail" by wrapping it in a C block: use Test::More tests => 1; TODO: { local $TODO = 'ical($ical) not yet implemented'; my $ical = Date::ICal->new; $ical->ical('20201231Z'); is( $ical->ical, '20201231Z', 'Setting via ical()' ); } Now when you run, it's a little different: 1..1 not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented # got: '20010822T201551Z' # expected: '20201231Z' L doesn't say "Looks like you failed 1 tests of 1". That '# TODO' tells L "this is supposed to fail" and it treats a failure as a successful test. You can write tests even before you've fixed the underlying code. If a TODO test passes, L will report it "UNEXPECTEDLY SUCCEEDED". When that happens, remove the TODO block with C and turn it into a real test. =head2 Testing with taint mode. Taint mode is a funny thing. It's the globalest of all global features. Once you turn it on, it affects I code in your program and I modules used (and all the modules they use). If a single piece of code isn't taint clean, the whole thing explodes. With that in mind, it's very important to ensure your module works under taint mode. It's very simple to have your tests run under taint mode. Just throw a C<-T> into the C<#!> line. L will read the switches in C<#!> and use them to run your tests. #!/usr/bin/perl -Tw ...test normally here... When you say C it will run with taint mode on. =head1 FOOTNOTES =over 4 =item 1 The first number doesn't really mean anything, but it has to be 1. It's the second number that's important. =item 2 For those following along at home, I'm using version 1.31. It has some bugs, which is good -- we'll uncover them with our tests. =item 3 You can actually take this one step further and test the manual itself. Have a look at L (formerly L). =item 4 Yes, there's a mistake in the test suite. What! Me, contrived? =item 5 We'll get to testing the contents of lists later. =item 6 But what happens if your test program dies halfway through?! Since we didn't say how many tests we're going to run, how can we know it failed? No problem, L employs some magic to catch that death and turn the test into a failure, even if every test passed up to that point. =item 7 I cleaned it up a little. =item 8 Most Operating Systems record time as the number of seconds since a certain date. This date is the beginning of the epoch. Unix's starts at midnight January 1st, 1970 GMT. =item 9 MacOS's epoch is midnight January 1st, 1904. VMS's is midnight, November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a problem. =item 10 As long as the code inside the SKIP block at least compiles. Please don't ask how. No, it's not a filter. =item 11 Do NOT be tempted to use TODO tests as a way to avoid fixing simple bugs! =back =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE and the perl-qa dancers! =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This documentation is free; you can redistribute it and/or modify it under the same terms as Perl itself. Irrespective of its distribution, all code examples in these files are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. =cut Tools000755001750001750 014772042322 17370 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesRef.t100644001750001750 545614772042322 20443 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; require_ok.t100644001750001750 142214772042322 20515 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 8; # Symbol and Class::Struct are both non-XS core modules back to 5.004. # So they'll always be there. require_ok("Symbol"); ok( $INC{'Symbol.pm'}, "require_ok MODULE" ); require_ok("Class/Struct.pm"); ok( $INC{'Class/Struct.pm'}, "require_ok FILE" ); # Its more trouble than its worth to try to create these filepaths to test # through require_ok() so we cheat and use the internal logic. ok !Test::More::_is_module_name('foo:bar'); ok !Test::More::_is_module_name('foo/bar.thing'); ok !Test::More::_is_module_name('Foo::Bar::'); ok Test::More::_is_module_name('V'); subtest000755001750001750 014772042322 17515 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacydo.t100644001750001750 43314772042322 20424 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # Test the idiom of running another test file as a subtest. use strict; use Test::More; pass("First"); my $file = "./t/Legacy/subtest/for_do_t.test"; ok -e $file, "subtest test file exists"; subtest $file => sub { do $file }; pass("Last"); done_testing(4); modules000755001750001750 014772042322 17271 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2IPC.t100644001750001750 64614772042322 20217 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesuse strict; use warnings; use Test2::IPC qw/cull/; use Test2::API qw/context test2_ipc_drivers test2_ipc intercept/; use Test2::Tools::Tiny; test2_ipc(); is_deeply( [test2_ipc_drivers()], ['Test2::IPC::Driver::Files'], "Default driver" ); ok(__PACKAGE__->can('cull'), "Imported cull"); ok(eval { intercept { Test2::IPC->import }; 1 }, "Can re-import Test2::IPC without error") or diag $@; done_testing; Hub.t100644001750001750 2722014772042322 20357 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/context test2_ipc_drivers/; use Test2::Util qw/CAN_FORK CAN_THREAD CAN_REALLY_FORK/; { package My::Formatter; sub new { bless [], shift }; my $check = 1; sub write { my $self = shift; my ($e, $count) = @_; push @$self => $e; } } { package My::Event; use base 'Test2::Event'; use Test2::Util::HashBase qw{msg}; } tests basic => sub { my $hub = Test2::Hub->new( formatter => My::Formatter->new, ); my $send_event = sub { my ($msg) = @_; my $e = My::Event->new(msg => $msg, trace => Test2::EventFacet::Trace->new(frame => ['fake', 'fake.t', 1])); $hub->send($e); }; ok(my $e1 = $send_event->('foo'), "Created event"); ok(my $e2 = $send_event->('bar'), "Created event"); ok(my $e3 = $send_event->('baz'), "Created event"); my $old = $hub->format(My::Formatter->new); ok($old->isa('My::Formatter'), "old formatter"); is_deeply( $old, [$e1, $e2, $e3], "Formatter got all events" ); }; tests follow_ups => sub { my $hub = Test2::Hub->new; $hub->set_count(1); my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, __LINE__], ); my $ran = 0; $hub->follow_up(sub { my ($d, $h) = @_; is_deeply($d, $trace, "Got trace"); is_deeply($h, $hub, "Got hub"); ok(!$hub->ended, "Hub state has not ended yet"); $ran++; }); like( exception { $hub->follow_up('xxx') }, qr/follow_up only takes coderefs for arguments, got 'xxx'/, "follow_up takes a coderef" ); $hub->finalize($trace); is($ran, 1, "ran once"); is_deeply( $hub->ended, $trace->frame, "Ended at the expected place." ); eval { $hub->finalize($trace) }; is($ran, 1, "ran once"); $hub = undef; }; tests IPC => sub { my ($driver) = test2_ipc_drivers(); is($driver, 'Test2::IPC::Driver::Files', "Default Driver"); my $ipc = $driver->new; my $hub = Test2::Hub->new( formatter => My::Formatter->new, ipc => $ipc, ); my $build_event = sub { my ($msg) = @_; return My::Event->new(msg => $msg, trace => Test2::EventFacet::Trace->new(frame => ['fake', 'fake.t', 1])); }; my $e1 = $build_event->('foo'); my $e2 = $build_event->('bar'); my $e3 = $build_event->('baz'); my $do_send = sub { $hub->send($e1); $hub->send($e2); $hub->send($e3); }; my $do_check = sub { my $name = shift; my $old = $hub->format(My::Formatter->new); ok($old->isa('My::Formatter'), "old formatter"); is(@$old, 3, "Formatter got all events ($name)"); ok($_->{hubs}, "Set the hubs") for @$old; }; if (CAN_REALLY_FORK) { my $pid = fork(); die "Could not fork!" unless defined $pid; if ($pid) { is(waitpid($pid, 0), $pid, "waited properly"); ok(!$?, "child exited with success"); $hub->cull(); $do_check->('Fork'); } else { $do_send->(); exit 0; } } if (CAN_THREAD && "$]" >= 5.010) { require threads; my $thr = threads->new(sub { $do_send->() }); $thr->join; $hub->cull(); $do_check->('Threads'); } $do_send->(); $hub->cull(); $do_check->('no IPC'); }; tests listen => sub { my $hub = Test2::Hub->new(); my @events; my @counts; my $it = $hub->listen(sub { my ($h, $e, $count) = @_; is_deeply($h, $hub, "got hub"); push @events => $e; push @counts => $count; }); my $second; my $it2 = $hub->listen(sub { $second++ }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->unlisten($it); $hub->send($ok3); is_deeply(\@counts, [1, 2], "Got counts"); is_deeply(\@events, [$ok1, $ok2], "got events"); is($second, 3, "got all events in listener that was not removed"); like( exception { $hub->listen('xxx') }, qr/listen only takes coderefs for arguments, got 'xxx'/, "listen takes a coderef" ); }; tests metadata => sub { my $hub = Test2::Hub->new(); my $default = { foo => 1 }; my $meta = $hub->meta('Foo', $default); is_deeply($meta, $default, "Set Meta"); $meta = $hub->meta('Foo', {}); is_deeply($meta, $default, "Same Meta"); $hub->delete_meta('Foo'); is($hub->meta('Foo'), undef, "No Meta"); $hub->meta('Foo', {})->{xxx} = 1; is($hub->meta('Foo')->{xxx}, 1, "Vivified meta and set it"); like( exception { $hub->meta(undef) }, qr/Invalid META key: undef, keys must be true, and may not be references/, "Cannot use undef as a meta key" ); like( exception { $hub->meta(0) }, qr/Invalid META key: '0', keys must be true, and may not be references/, "Cannot use 0 as a meta key" ); like( exception { $hub->delete_meta(undef) }, qr/Invalid META key: undef, keys must be true, and may not be references/, "Cannot use undef as a meta key" ); like( exception { $hub->delete_meta(0) }, qr/Invalid META key: '0', keys must be true, and may not be references/, "Cannot use 0 as a meta key" ); }; tests filter => sub { my $hub = Test2::Hub->new(); my @events; my $it = $hub->filter(sub { my ($h, $e) = @_; is($h, $hub, "got hub"); push @events => $e; return $e; }); my $count; my $it2 = $hub->filter(sub { $count++; $_[1] }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->unfilter($it); $hub->send($ok3); is_deeply(\@events, [$ok1, $ok2], "got events"); is($count, 3, "got all events, even after other filter was removed"); $hub = Test2::Hub->new(); @events = (); $hub->filter(sub { undef }); $hub->listen(sub { my ($hub, $e) = @_; push @events => $e; }); $hub->send($ok1); $hub->send($ok2); $hub->send($ok3); ok(!@events, "Blocked events"); like( exception { $hub->filter('xxx') }, qr/filter only takes coderefs for arguments, got 'xxx'/, "filter takes a coderef" ); }; tests pre_filter => sub { my $hub = Test2::Hub->new(); my @events; my $it = $hub->pre_filter(sub { my ($h, $e) = @_; is($h, $hub, "got hub"); push @events => $e; return $e; }); my $count; my $it2 = $hub->pre_filter(sub { $count++; $_[1] }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->pre_unfilter($it); $hub->send($ok3); is_deeply(\@events, [$ok1, $ok2], "got events"); is($count, 3, "got all events, even after other pre_filter was removed"); $hub = Test2::Hub->new(); @events = (); $hub->pre_filter(sub { undef }); $hub->listen(sub { my ($hub, $e) = @_; push @events => $e; }); $hub->send($ok1); $hub->send($ok2); $hub->send($ok3); ok(!@events, "Blocked events"); like( exception { $hub->pre_filter('xxx') }, qr/pre_filter only takes coderefs for arguments, got 'xxx'/, "pre_filter takes a coderef" ); }; tests state => sub { my $hub = Test2::Hub->new; is($hub->count, 0, "count starts at 0"); is($hub->failed, 0, "failed starts at 0"); is($hub->is_passing, 1, "start off passing"); is($hub->plan, undef, "no plan yet"); $hub->is_passing(0); is($hub->is_passing, 0, "Can Fail"); $hub->is_passing(1); is($hub->is_passing, 1, "Passes again"); $hub->set_count(1); is($hub->count, 1, "Added a passing result"); is($hub->failed, 0, "still no fails"); is($hub->is_passing, 1, "Still passing"); $hub->set_count(2); $hub->set_failed(1); is($hub->count, 2, "Added a result"); is($hub->failed, 1, "new failure"); is($hub->is_passing, 0, "Not passing"); $hub->is_passing(1); is($hub->is_passing, 0, "is_passing always false after a failure"); $hub->set_failed(0); $hub->is_passing(1); is($hub->is_passing, 1, "Passes again"); $hub->set_failed(1); is($hub->count, 2, "No new result"); is($hub->failed, 1, "new failure"); is($hub->is_passing, 0, "Not passing"); ok(!eval { $hub->plan('foo'); 1 }, "Could not set plan to 'foo'"); like($@, qr/'foo' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'/, "Got expected error"); ok($hub->plan(5), "Can set plan to integer"); is($hub->plan, 5, "Set the plan to an integer"); $hub->set__plan(undef); ok($hub->plan('NO PLAN'), "Can set plan to 'NO PLAN'"); is($hub->plan, 'NO PLAN', "Set the plan to 'NO PLAN'"); $hub->set__plan(undef); ok($hub->plan('SKIP'), "Can set plan to 'SKIP'"); is($hub->plan, 'SKIP', "Set the plan to 'SKIP'"); ok(!eval { $hub->plan(5); 1 }, "Cannot change plan"); like($@, qr/You cannot change the plan/, "Got error"); my $trace = Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'foo.t', 42, 'blah']); $hub->finalize($trace); my $ok = eval { $hub->finalize($trace) }; my $err = $@; ok(!$ok, "died"); is($err, <<" EOT", "Got expected error"); Test already ended! First End: foo.t line 42 Second End: foo.t line 42 EOT $hub = Test2::Hub->new; $hub->plan(5); $hub->set_count(5); $hub->set_failed(1); $hub->set_ended($trace); $hub->set_bailed_out("foo"); $hub->set_skip_reason('xxx'); ok(!$hub->is_passing, "not passing"); $hub->reset_state; ok(!$hub->plan, "no plan"); is($hub->count, 0, "count reset to 0"); is($hub->failed, 0, "reset failures"); ok(!$hub->ended, "not ended"); ok(!$hub->bailed_out, "did not bail out"); ok(!$hub->skip_reason, "no skip reason"); }; done_testing; API.t100644001750001750 2247514772042322 20261 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesuse strict; use warnings; BEGIN { no warnings 'once'; $main::cleanup1 = bless {}, 'My::Cleanup' } use Test2::API qw/context/; my ($LOADED, $INIT); BEGIN { $INIT = Test2::API::test2_init_done; $LOADED = Test2::API::test2_load_done; }; use Test2::IPC; use Test2::Tools::Tiny; use Test2::Util qw/get_tid/; my $CLASS = 'Test2::API'; # Ensure we do not break backcompat later by removing anything ok(Test2::API->can($_), "$_ method is present") for qw{ context_do no_context test2_init_done test2_load_done test2_pid test2_tid test2_stack test2_no_wait test2_is_testing_done test2_add_callback_context_init test2_add_callback_context_release test2_add_callback_exit test2_add_callback_post_load test2_list_context_init_callbacks test2_list_context_release_callbacks test2_list_exit_callbacks test2_list_post_load_callbacks test2_ipc test2_ipc_disable test2_ipc_disabled test2_ipc_drivers test2_ipc_add_driver test2_ipc_polling test2_ipc_disable_polling test2_ipc_enable_polling test2_formatter test2_formatters test2_formatter_add test2_formatter_set }; ok(!$LOADED, "Was not load_done right away"); ok(!$INIT, "Init was not done right away"); ok(Test2::API::test2_load_done, "We loaded it"); # Note: This is a check that stuff happens in an END block. { { package FOLLOW; sub DESTROY { return if $_[0]->{fixed}; print "not ok - Did not run end ($_[0]->{name})!"; $? = 255; exit 255; } } our $kill1 = bless {fixed => 0, name => "Custom Hook"}, 'FOLLOW'; Test2::API::test2_add_callback_exit( sub { print "# Running END hook\n"; $kill1->{fixed} = 1; } ); our $kill2 = bless {fixed => 0, name => "set exit"}, 'FOLLOW'; my $old = Test2::API::Instance->can('set_exit'); no warnings 'redefine'; *Test2::API::Instance::set_exit = sub { $kill2->{fixed} = 1; print "# Running set_exit\n"; $old->(@_); }; } ok($CLASS->can('test2_init_done')->(), "init is done."); ok($CLASS->can('test2_load_done')->(), "Test2 is finished loading"); is($CLASS->can('test2_pid')->(), $$, "got pid"); is($CLASS->can('test2_tid')->(), get_tid(), "got tid"); ok($CLASS->can('test2_stack')->(), 'got stack'); is($CLASS->can('test2_stack')->(), $CLASS->can('test2_stack')->(), "always get the same stack"); ok($CLASS->can('test2_ipc')->(), 'got ipc'); is($CLASS->can('test2_ipc')->(), $CLASS->can('test2_ipc')->(), "always get the same IPC"); is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/Test2::IPC::Driver::Files/], "Got driver list"); # Verify it reports to the correct file/line, there was some trouble with this... my $file = __FILE__; my $line = __LINE__ + 1; my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') }; my $sub1 = sub { like( $warnings->[0], qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line}, "got warning about adding driver too late" ); }; if ("$]" <= 5.006002) { todo("TODO known to fail on $]", $sub1); } else { $sub1->(); } is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list"); ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); $CLASS->can('test2_ipc_disable_polling')->(); ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off"); $CLASS->can('test2_ipc_enable_polling')->(); ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); ok($CLASS->can('test2_formatter')->(), "Got a formatter"); is($CLASS->can('test2_formatter')->(), $CLASS->can('test2_formatter')->(), "always get the same Formatter (class name)"); my $ran = 0; $CLASS->can('test2_add_callback_post_load')->(sub { $ran++ }); is($ran, 1, "ran the post-load"); like( exception { $CLASS->can('test2_formatter_set')->() }, qr/No formatter specified/, "formatter_set requires an argument" ); like( exception { $CLASS->can('test2_formatter_set')->('fake') }, qr/Global Formatter already set/, "formatter_set doesn't work after initialization", ); ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); $CLASS->can('test2_no_wait')->(1); ok($CLASS->can('test2_no_wait')->(), "no_wait is set"); $CLASS->can('test2_no_wait')->(undef); ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled"); $CLASS->can('test2_ipc_wait_disable')->(); ok(!$CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting disabled"); $CLASS->can('test2_ipc_wait_enable')->(); ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled"); my $pctx; sub tool_a($;$) { Test2::API::context_do { my $ctx = shift; my ($bool, $name) = @_; $pctx = wantarray; die "xyz" unless $bool; $ctx->ok($bool, $name); return unless defined $pctx; return (1, 2) if $pctx; return 'a'; } @_; } $pctx = 'x'; tool_a(1, "void context test"); ok(!defined($pctx), "void context"); my $x = tool_a(1, "scalar context test"); ok(defined($pctx) && $pctx == 0, "scalar context"); is($x, 'a', "got scalar return"); my @x = tool_a(1, "array context test"); ok($pctx, "array context"); is_deeply(\@x, [1, 2], "Got array return"); like( exception { tool_a(0) }, qr/^xyz/, "got exception" ); sub { my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context()"); $inner->release; }; $middle->release; }->(); $outer->release; }->(); sub { my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); $inner->release; } $outer->hub->hid; $middle->release; }->(); $outer->release; }->(); sub { my @warnings; my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); local $SIG{__WARN__} = sub { push @warnings => @_ }; Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); } $outer->hub->hid; $middle->release; }->(); $outer->release; is(@warnings, 1, "1 warning"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "Got warning about unreleased context" ); }->(); sub { my $hub = Test2::Hub->new(); my $ctx = context(hub => $hub); is($ctx->hub,$hub, 'got the hub of context() argument'); $ctx->release; }->(); my $sub = sub { }; Test2::API::test2_add_callback_context_acquire($sub); Test2::API::test2_add_callback_context_init($sub); Test2::API::test2_add_callback_context_release($sub); Test2::API::test2_add_callback_exit($sub); Test2::API::test2_add_callback_post_load($sub); is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 1, "got the one instance of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 1, "got the one instance of the hook"); Test2::API::test2_add_callback_context_acquire($sub); Test2::API::test2_add_callback_context_init($sub); Test2::API::test2_add_callback_context_release($sub); Test2::API::test2_add_callback_exit($sub); Test2::API::test2_add_callback_post_load($sub); is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 2, "got the two instances of the hook"); ok(!Test2::API::test2_is_testing_done(), "Testing is not done"); done_testing; die "Testing should be done, but it is not!" unless Test2::API::test2_is_testing_done(); { package My::Cleanup; sub DESTROY { return if Test2::API::test2_is_testing_done(); print "not ok - Testing should be done, but it is not!\n"; warn "Testing should be done, but it is not!"; eval "END { $? = 255 }; 1" or die $@; exit 255; } } # This should destroy the thing END { no warnings 'once'; $main::cleanup2 = bless {}, 'My::Cleanup' } Formatter.pm100644001750001750 755614772042322 20602 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::Formatter; use strict; use warnings; our $VERSION = '1.302210'; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; require Test2::API; Test2::API::test2_formatter_add($class); } sub new_root { my $class = shift; return $class->new(@_); } sub supports_tables { 0 } sub hide_buffered { 1 } sub terminate { } sub finalize { } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter - Namespace for formatters. =head1 DESCRIPTION This is the namespace for formatters. This is an empty package. =head1 CREATING FORMATTERS A formatter is any package or object with a C method. package Test2::Formatter::Foo; use strict; use warnings; sub write { my $self_or_class = shift; my ($event, $assert_num) = @_; ... } sub hide_buffered { 1 } sub terminate { } sub finalize { } sub supports_tables { return $BOOL } sub new_root { my $class = shift; ... $class->new(@_); } 1; The C method is a method, so it either gets a class or instance. The two arguments are the C<$event> object it should record, and the C<$assert_num> which is the number of the current assertion (ok), or the last assertion if this event is not itself an assertion. The assertion number may be any integer 0 or greater, and may be undefined in some cases. The C method must return a boolean. This is used to tell buffered subtests whether or not to send it events as they are being buffered. See L for more information. The C and C methods are optional methods called that you can implement if the format you're generating needs to handle these cases, for example if you are generating XML and need close open tags. The C method is called when an event's C method returns true, for example when a L has a C<'skip_all'> plan, or when a L event is sent. The C method is passed a single argument, the L object which triggered the terminate. The C method is always the last thing called on the formatter, I<< except when C is called for a Bail event >>. It is passed the following arguments: The C method should be true if the formatter supports directly rendering table data from the C facets. This is a newer feature and many older formatters may not support it. When not supported the formatter falls back to rendering C instead of the C data. The C method is used when constructing a root formatter. The default is to just delegate to the regular C method, most formatters can ignore this. =over 4 =item * The number of tests that were planned =item * The number of tests actually seen =item * The number of tests which failed =item * A boolean indicating whether or not the test suite passed =item * A boolean indicating whether or not this call is for a subtest =back The C method is called when C Initializes the root hub for the first time. Most formatters will simply have this call C<< $class->new >>, which is the default behavior. Some formatters however may want to take extra action during construction of the root formatter, this is where they can do that. =head1 SOURCE The source code repository for Test2 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 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 API000755001750001750 014772042322 16535 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Stack.pm100644001750001750 1137314772042322 20325 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/APIpackage Test2::API::Stack; use strict; use warnings; our $VERSION = '1.302210'; use Test2::Hub(); use Carp qw/confess/; sub new { my $class = shift; return bless [], $class; } sub new_hub { my $self = shift; my %params = @_; my $class = delete $params{class} || 'Test2::Hub'; my $hub = $class->new(%params); if (@$self) { $hub->inherit($self->[-1], %params); } else { require Test2::API; $hub->format(Test2::API::test2_formatter()->new_root) unless $hub->format || exists($params{formatter}); my $ipc = Test2::API::test2_ipc(); if ($ipc && !$hub->ipc && !exists($params{ipc})) { $hub->set_ipc($ipc); $ipc->add_hub($hub->hid); } } push @$self => $hub; $hub; } sub top { my $self = shift; return $self->new_hub unless @$self; return $self->[-1]; } sub peek { my $self = shift; return @$self ? $self->[-1] : undef; } sub cull { my $self = shift; $_->cull for reverse @$self; } sub all { my $self = shift; return @$self; } sub root { my $self = shift; return unless @$self; return $self->[0]; } sub clear { my $self = shift; @$self = (); } # Do these last without keywords in order to prevent them from getting used # when we want the real push/pop. { no warnings 'once'; *push = sub { my $self = shift; my ($hub) = @_; $hub->inherit($self->[-1]) if @$self; push @$self => $hub; }; *pop = sub { my $self = shift; my ($hub) = @_; confess "No hubs on the stack" unless @$self; confess "You cannot pop the root hub" if 1 == @$self; confess "Hub stack mismatch, attempted to pop incorrect hub" unless $self->[-1] == $hub; pop @$self; }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Stack - Object to manage a stack of L instances. =head1 ***INTERNALS NOTE*** B The public methods provided will not change in backwards incompatible ways, but the underlying implementation details might. B =head1 DESCRIPTION This module is used to represent and manage a stack of L objects. Hubs are usually in a stack so that you can push a new hub into place that can intercept and handle events differently than the primary hub. =head1 SYNOPSIS my $stack = Test2::API::Stack->new; my $hub = $stack->top; =head1 METHODS =over 4 =item $stack = Test2::API::Stack->new() This will create a new empty stack instance. All arguments are ignored. =item $hub = $stack->new_hub() =item $hub = $stack->new_hub(%params) =item $hub = $stack->new_hub(%params, class => $class) This will generate a new hub and push it to the top of the stack. Optionally you can provide arguments that will be passed into the constructor for the L object. If you specify the C<< 'class' => $class >> argument, the new hub will be an instance of the specified class. Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the formatter and IPC instance will be inherited from the current top hub. You can set the parameters to C to avoid having a formatter or IPC instance. If there is no top hub, and you do not ask to leave IPC and formatter undef, then a new formatter will be created, and the IPC instance from L will be used. =item $hub = $stack->top() This will return the top hub from the stack. If there is no top hub yet this will create it. =item $hub = $stack->peek() This will return the top hub from the stack. If there is no top hub yet this will return undef. =item $stack->cull This will call C<< $hub->cull >> on all hubs in the stack. =item @hubs = $stack->all This will return all the hubs in the stack as a list. =item $stack->clear This will completely remove all hubs from the stack. Normally you do not want to do this, but there are a few valid reasons for it. =item $stack->push($hub) This will push the new hub onto the stack. =item $stack->pop($hub) This will pop a hub from the stack, if the hub at the top of the stack does not match the hub you expect (passed in as an argument) it will throw an exception. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Term.pm100644001750001750 44314772042322 20427 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Term; use strict; use warnings; use Term::Table::Util qw/term_size USE_GCS USE_TERM_READKEY uni_length/; our $VERSION = '1.302210'; use Test2::Util::Importer 'Test2::Util::Importer' => 'import'; our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY uni_length/; 1; Tools000755001750001750 014772042322 17224 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Ref.pm100644001750001750 716114772042322 20443 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Ref; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Stash.t100644001750001750 632514772042322 20622 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Utiluse 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; Times.t100644001750001750 205014772042322 20610 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Utiluse 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; Table.t100644001750001750 1743314772042322 20611 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Utiluse 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; Grab.t100644001750001750 110414772042322 20564 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Mock.t100644001750001750 1761514772042322 20640 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Spec.t100644001750001750 14014772042322 20562 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse Test2::Bundle::Extended -target => 'Test2::Tools::Spec'; skip_all "Tests not yet written"; filtering.t100644001750001750 6151114772042322 20753 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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; filehandles.t100644001750001750 44214772042322 20607 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } } use lib 't/lib'; use Test::More tests => 1; use Dev::Null; tie *STDOUT, "Dev::Null" or die $!; print "not ok 1\n"; # this should not print. pass 'STDOUT can be mucked with'; check_tests.t100644001750001750 460514772042322 20655 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use Test::Tester; use Data::Dumper qw(Dumper); my $test = Test::Builder->new; $test->plan(tests => 139); my $cap; $cap = Test::Tester->capture; my @tests = ( [ 'pass', '$cap->ok(1, "pass");', { name => "pass", ok => 1, actual_ok => 1, reason => "", type => "", diag => "", depth => 0, }, ], [ 'pass diag', '$cap->ok(1, "pass diag"); $cap->diag("pass diag1"); $cap->diag("pass diag2");', { name => "pass diag", ok => 1, actual_ok => 1, reason => "", type => "", diag => "pass diag1\npass diag2\n", depth => 0, }, ], [ 'pass diag no \\n', '$cap->ok(1, "pass diag"); $cap->diag("pass diag1"); $cap->diag("pass diag2");', { name => "pass diag", ok => 1, actual_ok => 1, reason => "", type => "", diag => "pass diag1\npass diag2", depth => 0, }, ], [ 'fail', '$cap->ok(0, "fail"); $cap->diag("fail diag");', { name => "fail", ok => 0, actual_ok => 0, reason => "", type => "", diag => "fail diag\n", depth => 0, }, ], [ 'skip', '$cap->skip("just because");', { name => "", ok => 1, actual_ok => 1, reason => "just because", type => "skip", diag => "", depth => 0, }, ], [ 'todo_skip', '$cap->todo_skip("why not");', { name => "", ok => 1, actual_ok => 0, reason => "why not", type => "todo_skip", diag => "", depth => 0, }, ], [ 'pass diag qr', '$cap->ok(1, "pass diag qr"); $cap->diag("pass diag qr");', { name => "pass diag qr", ok => 1, actual_ok => 1, reason => "", type => "", diag => qr/pass diag qr/, depth => 0, }, ], [ 'fail diag qr', '$cap->ok(0, "fail diag qr"); $cap->diag("fail diag qr");', { name => "fail diag qr", ok => 0, actual_ok => 0, reason => "", type => "", diag => qr/fail diag qr/, depth => 0, }, ], ); my $big_code = ""; my @big_expect; foreach my $test (@tests) { my ($name, $code, $expect) = @$test; $big_code .= "$code\n"; push(@big_expect, $expect); my $test_sub = eval "sub {$code}"; check_test($test_sub, $expect, $name); } my $big_test_sub = eval "sub {$big_code}"; check_tests($big_test_sub, \@big_expect, "run all"); Simple000755001750001750 014772042322 17255 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyload.t100644001750001750 26414772042322 20503 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Simple#!/usr/bin/perl # Because I broke "use Test::Simple", here's a test use strict; use warnings; use Test::Simple; print <new; { my $tb = Test::Builder::NoOutput->create; $tb->ok(1); $Test->ok( !eval { $tb->subtest("death" => sub { die "Death in the subtest"; }); 1; }); $Test->like( $@, qr/^Death in the subtest at \Q$0\E line /); $Test->ok( !$tb->parent, "the parent object is restored after a die" ); } $Test->done_testing(); Builder000755001750001750 014772042322 17412 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacytry.t100644001750001750 135314772042322 20557 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More 'no_plan'; require Test::Builder; my $tb = Test::Builder->new; # Test that _try() has no effect on $@ and $! and is not effected by # __DIE__ { local $SIG{__DIE__} = sub { fail("DIE handler called: @_") }; local $@ = 42; local $! = 23; is $tb->_try(sub { 2 }), 2; is $tb->_try(sub { return '' }), ''; is $tb->_try(sub { die; }), undef; is_deeply [$tb->_try(sub { die "Foo\n" })], [undef, "Foo\n"]; is $@, 42; cmp_ok $!, '==', 23; } ok !eval { $tb->_try(sub { die "Died\n" }, die_on_fail => 1); }; is $@, "Died\n"; Util.t100644001750001750 435314772042322 20540 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesuse strict; use warnings; our $TIME; BEGIN { *CORE::GLOBAL::time = sub() { return CORE::time() unless defined $TIME; return $TIME; }; } use Config qw/%Config/; use Test2::Tools::Tiny; use Test2::Util qw/ try get_tid USE_THREADS pkg_to_file CAN_FORK CAN_THREAD CAN_REALLY_FORK ipc_separator gen_uid CAN_SIGSYS IS_WIN32 clone_io /; { for my $try (\&try, Test2::Util->can('_manual_try'), Test2::Util->can('_local_try')) { my ($ok, $err) = $try->(sub { die "xxx" }); ok(!$ok, "cought exception"); like($err, qr/xxx/, "expected exception"); ($ok, $err) = $try->(sub { 0 }); ok($ok, "Success"); ok(!$err, "no error"); } } is(pkg_to_file('A::Package::Name'), 'A/Package/Name.pm', "Converted package to file"); # Make sure running them does not die # We cannot really do much to test these. CAN_THREAD(); CAN_FORK(); CAN_REALLY_FORK(); IS_WIN32(); is(IS_WIN32(), ($^O eq 'MSWin32') ? 1 : 0, "IS_WIN32 is correct ($^O)"); my %sigs = map {$_ => 1} split /\s+/, $Config{sig_name}; if ($sigs{SYS}) { ok(CAN_SIGSYS, "System has SIGSYS"); } else { ok(!CAN_SIGSYS, "System lacks SIGSYS"); } my $check_for_sig_sys = Test2::Util->can('_check_for_sig_sys'); ok($check_for_sig_sys->("FOO SYS BAR"), "Found SIGSYS in the middle"); ok($check_for_sig_sys->("SYS FOO BAR"), "Found SIGSYS at start"); ok($check_for_sig_sys->("FOO BAR SYS"), "Found SIGSYS at end"); ok(!$check_for_sig_sys->("FOO SYSX BAR"), "SYSX is not SYS"); ok(!$check_for_sig_sys->("FOO XSYS BAR"), "XSYS is not SYS"); my $io = clone_io(\*STDOUT); ok($io, "Cloned the filehandle"); close($io); my $fh; my $out = ''; open($fh, '>', \$out) or die "Could not open filehandle"; $io = clone_io($fh); is($io, $fh, "For a scalar handle we simply return the original handle, no other choice"); print $io "Test\n"; is($out, "Test\n", "wrote to the scalar handle"); is(ipc_separator(), '~', "Got ipc_separator"); { local $TIME = time; my $id1 = gen_uid(); my $id2 = gen_uid(); like($id1, qr/^\Q$$~0~$TIME~\E\d+$/, "Got a UID ($id1)"); my ($inc) = ($id1 =~ m/(\d+)$/g); $inc++; is($id2, "$$~0~$TIME~$inc", "Next id is next in sequence ($id2)"); } done_testing; MyTest000755001750001750 014772042322 16613 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/libTarget.pm100644001750001750 24214772042322 20515 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/MyTestpackage MyTest::Target; use Carp qw/confess/; use overload bool => sub { confess( 'illegal use of overloaded bool') } ; use overload '""' => sub { $_[0] }; 1; EventFacet.pm100644001750001750 272314772042322 20652 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::EventFacet; use strict; use warnings; our $VERSION = '1.302210'; use Test2::Util::HashBase qw/-details/; use Carp qw/croak/; my $SUBLEN = length(__PACKAGE__ . '::'); sub facet_key { my $key = ref($_[0]) || $_[0]; substr($key, 0, $SUBLEN, ''); return lc($key); } sub is_list { 0 } sub clone { my $self = shift; my $type = ref($self); return bless {%$self, @_}, $type; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet - Base class for all event facets. =head1 DESCRIPTION Base class for all event facets. =head1 METHODS =over 4 =item $key = $facet_class->facet_key() This will return the key for the facet in the facet data hash. =item $bool = $facet_class->is_list() This will return true if the facet should be in a list instead of a single item. =item $clone = $facet->clone() =item $clone = $facet->clone(%replace) This will make a shallow clone of the facet. You may specify fields to override as arguments. =back =head1 SOURCE The source code repository for Test2 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 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 Plan.pm100644001750001750 647114772042322 20605 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Plan; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{max directive reason}; use Carp qw/confess/; my %ALLOWED = ( 'SKIP' => 1, 'NO PLAN' => 1, ); sub init { if ($_[0]->{+DIRECTIVE}) { $_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all'; $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan'; confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive" unless $ALLOWED{$_[0]->{+DIRECTIVE}}; } else { confess "Cannot have a reason without a directive!" if defined $_[0]->{+REASON}; confess "No number of tests specified" unless defined $_[0]->{+MAX}; confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer" unless $_[0]->{+MAX} =~ m/^\d+$/; $_[0]->{+DIRECTIVE} = ''; } } sub sets_plan { my $self = shift; return ( $self->{+MAX}, $self->{+DIRECTIVE}, $self->{+REASON}, ); } sub terminate { my $self = shift; # On skip_all we want to terminate the hub return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; return undef; } sub summary { my $self = shift; my $max = $self->{+MAX}; my $directive = $self->{+DIRECTIVE}; my $reason = $self->{+REASON}; return "Plan is $max assertions" if $max || !$directive; return "Plan is '$directive', $reason" if $reason; return "Plan is '$directive'"; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef unless defined $out->{control}->{terminate}; $out->{plan} = {count => $self->{+MAX}}; $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON}; if (my $dir = $self->{+DIRECTIVE}) { $out->{plan}->{skip} = 1 if $dir eq 'SKIP'; $out->{plan}->{none} = 1 if $dir eq 'NO PLAN'; } return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Plan - The event of a plan =head1 DESCRIPTION Plan events are fired off whenever a plan is declared, done testing is called, or a subtext completes. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Plan; my $ctx = context(); # Plan for 10 tests to run my $event = $ctx->plan(10); # Plan to skip all tests (will exit 0) $ctx->plan(0, skip_all => "These tests need to be skipped"); =head1 ACCESSORS =over 4 =item $num = $plan->max Get the number of expected tests =item $dir = $plan->directive Get the directive (such as TODO, skip_all, or no_plan). =item $reason = $plan->reason Get the reason for the directive. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Bail.pm100644001750001750 323514772042322 20555 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Bail; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{reason buffered}; # Make sure the tests terminate sub terminate { 255 }; sub global { 1 }; sub causes_fail { 1 } sub summary { my $self = shift; return "Bail out! " . $self->{+REASON} if $self->{+REASON}; return "Bail out!"; } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control} = { global => 1, halt => 1, details => $self->{+REASON}, terminate => 255, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Bail - Bailout! =head1 DESCRIPTION The bailout event is generated when things go horribly wrong and you need to halt all testing in the current file. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Bail; my $ctx = context(); my $event = $ctx->bail('Stuff is broken'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $reason = $e->reason The reason for the bailout. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Pass.pm100644001750001750 361314772042322 20614 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Pass; use strict; use warnings; our $VERSION = '1.302210'; use Test2::EventFacet::Info; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event); *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; } use Test2::Util::HashBase qw{ -name -info }; ############## # Old API sub summary { "pass" } sub increments_count { 1 } sub causes_fail { 0 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub terminate { () } sub global { () } sub sets_plan { () } ############## # New API sub add_info { my $self = shift; for my $in (@_) { $in = {%$in} if ref($in) ne 'ARRAY'; $in = Test2::EventFacet::Info->new($in); push @{$self->{+INFO}} => $in; } } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = 'pass'; $out->{assert} = {pass => 1, details => $self->{+NAME}}; $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Pass - Event for a simple passing assertion =head1 DESCRIPTION This is an optimal representation of a passing assertion. =head1 SYNOPSIS use Test2::API qw/context/; sub pass { my ($name) = @_; my $ctx = context(); $ctx->pass($name); $ctx->release; } =head1 SOURCE The source code repository for Test2 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 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 Diag.pm100644001750001750 265414772042322 20556 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Diag; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } sub summary { $_[0]->{+MESSAGE} } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{info} = [ { tag => 'DIAG', debug => 1, details => $self->{+MESSAGE}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Diag - Diag event type =head1 DESCRIPTION Diagnostics messages, typically rendered to STDERR. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Diag; my $ctx = context(); my $event = $ctx->diag($message); =head1 ACCESSORS =over 4 =item $diag->message The message for the diag. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Note.pm100644001750001750 260614772042322 20614 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Note; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } sub summary { $_[0]->{+MESSAGE} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{info} = [ { tag => 'NOTE', debug => 0, details => $self->{+MESSAGE}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Note - Note event type =head1 DESCRIPTION Notes, typically rendered to STDOUT. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Note; my $ctx = context(); my $event = $ctx->Note($message); =head1 ACCESSORS =over 4 =item $note->message The message for the note. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Skip.pm100644001750001750 371114772042322 20613 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Skip; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{reason}; sub init { my $self = shift; $self->SUPER::init; $self->{+EFFECTIVE_PASS} = 1; } sub causes_fail { 0 } sub summary { my $self = shift; my $out = $self->SUPER::summary(@_); if (my $reason = $self->reason) { $out .= " (SKIP: $reason)"; } else { $out .= " (SKIP)"; } return $out; } sub extra_amnesty { my $self = shift; my @out; push @out => { tag => 'TODO', details => $self->{+TODO}, } if defined $self->{+TODO}; push @out => { tag => 'skip', details => $self->{+REASON}, inherited => 0, }; return @out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Skip - Skip event type =head1 DESCRIPTION Skip events bump test counts just like L events, but they can never fail. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Skip; my $ctx = context(); my $event = $ctx->skip($name, $reason); or: my $ctx = context(); my $event = $ctx->send_event( 'Skip', name => $name, reason => $reason, ); =head1 ACCESSORS =over 4 =item $reason = $e->reason The original true/false value of whatever was passed into the event (but reduced down to 1 or 0). =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Fail.pm100644001750001750 373714772042322 20570 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Fail; use strict; use warnings; our $VERSION = '1.302210'; use Test2::EventFacet::Info; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event); *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; } use Test2::Util::HashBase qw{ -name -info }; ############# # Old API sub summary { "fail" } sub increments_count { 1 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub terminate { () } sub global { () } sub sets_plan { () } sub causes_fail { my $self = shift; return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}}; return 1; } ############# # New API sub add_info { my $self = shift; for my $in (@_) { $in = {%$in} if ref($in) ne 'ARRAY'; $in = Test2::EventFacet::Info->new($in); push @{$self->{+INFO}} => $in; } } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = 'fail'; $out->{assert} = {pass => 0, details => $self->{+NAME}}; $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Fail - Event for a simple failed assertion =head1 DESCRIPTION This is an optimal representation of a failed assertion. =head1 SYNOPSIS use Test2::API qw/context/; sub fail { my ($name) = @_; my $ctx = context(); $ctx->fail($name); $ctx->release; } =head1 SOURCE The source code repository for Test2 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 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 Trace.pm100644001750001750 156014772042322 20577 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Trace; require Test2::EventFacet::Trace; use warnings; use strict; our @ISA = ('Test2::EventFacet::Trace'); our $VERSION = '1.302210'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Trace - Legacy wrapper for L. =head1 DESCRIPTION All the functionality for this class has been moved to L. =head1 SOURCE The source code repository for Test2 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 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 Stash.pm100644001750001750 1321114772042322 20637 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Stash; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Guard.pm100644001750001750 240614772042322 20603 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Guard; use strict; use warnings; use Carp qw(confess); our $VERSION = '1.302210'; 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 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 Times.pm100644001750001750 612614772042322 20625 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Times; use strict; use warnings; use List::Util qw/sum/; our $VERSION = '1.302210'; 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 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 Table.pm100644001750001750 1146514772042322 20615 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Table; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Grab.pm100644001750001750 475614772042322 20611 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Grab; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Mock.pm100644001750001750 3112314772042322 20633 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage 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 = '1.302210'; 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 references (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 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 Tiny.pm100644001750001750 2102014772042322 20660 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Tiny; use strict; use warnings; use Scalar::Util qw/blessed/; use Test2::Util qw/try/; use Test2::API qw/context run_subtest test2_stack/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); our $VERSION = '1.302210'; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT = qw{ ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing warnings exception tests capture }; sub ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub is($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" eq "$want"; } elsif (defined($got) xor defined($want)) { $bool = 0; } else { # Both are undef $bool = 1; } return $ctx->pass_and_release($name) if $bool; $got = '*NOT DEFINED*' unless defined $got; $want = '*NOT DEFINED*' unless defined $want; unshift @diag => ( "GOT: $got", "EXPECTED: $want", ); return $ctx->fail_and_release($name, @diag); } sub isnt($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" ne "$want"; } elsif (defined($got) xor defined($want)) { $bool = 1; } else { # Both are undef $bool = 0; } return $ctx->pass_and_release($name) if $bool; unshift @diag => "Strings are the same (they should not be)" unless $bool; return $ctx->fail_and_release($name, @diag); } sub like($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" =~ $pattern; unshift @diag => ( "Value: $thing", "Does not match: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub unlike($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" !~ $pattern; unshift @diag => ( "Unexpected pattern match (it should not match)", "Value: $thing", "Matches: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub is_deeply($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); no warnings 'once'; require Data::Dumper; # Otherwise numbers might be unquoted local $Data::Dumper::Useperl = 1; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Freezer = 'XXX'; local *UNIVERSAL::XXX = sub { my ($thing) = @_; if (ref($thing)) { $thing = {%$thing} if "$thing" =~ m/=HASH/; $thing = [@$thing] if "$thing" =~ m/=ARRAY/; $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; } $_[0] = $thing; }; my $g = Data::Dumper::Dumper($got); my $w = Data::Dumper::Dumper($want); my $bool = $g eq $w; return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, $g, $w, @diag); } sub diag { my $ctx = context(); $ctx->diag(join '', @_); $ctx->release; } sub note { my $ctx = context(); $ctx->note(join '', @_); $ctx->release; } sub skip_all { my ($reason) = @_; my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release if $ctx; } sub todo { my ($reason, $sub) = @_; my $ctx = context(); # This code is mostly copied from Test2::Todo in the Test2-Suite # distribution. my $hub = test2_stack->top; my $filter = $hub->pre_filter( sub { my ($active_hub, $event) = @_; if ($active_hub == $hub) { $event->set_todo($reason) if $event->can('set_todo'); $event->add_amnesty({tag => 'TODO', details => $reason}); } else { $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1}); } return $event; }, inherit => 1, todo => $reason, ); $sub->(); $hub->pre_unfilter($filter); $ctx->release if $ctx; } sub plan { my ($max) = @_; my $ctx = context(); $ctx->plan($max); $ctx->release; } sub done_testing { my $ctx = context(); $ctx->done_testing; $ctx->release; } sub warnings(&) { my $code = shift; my @warnings; local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return \@warnings; } sub exception(&) { my $code = shift; local ($@, $!, $SIG{__DIE__}); my $ok = eval { $code->(); 1 }; my $error = $@ || 'SQUASHED ERROR'; return $ok ? undef : $error; } sub tests { my ($name, $code) = @_; my $ctx = context(); my $be = caller->can('before_each'); $be->($name) if $be; my $bool = run_subtest($name, $code, 1); $ctx->release; return $bool; } sub capture(&) { my $code = shift; my ($err, $out) = ("", ""); my $handles = test2_stack->top->format->handles; my ($ok, $e); { my ($out_fh, $err_fh); ($ok, $e) = try { # Scalar refs as filehandles were added in 5.8. open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); $code->(); }; } test2_stack->top->format->set_handles($handles); die $e unless $ok; $err =~ s/ $/_/mg; $out =~ s/ $/_/mg; return { STDOUT => $out, STDERR => $err, }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use L. =head1 DESCRIPTION You should really look at L. This package is some very basic essential tools implemented using L. This exists only so that L and other tools required by L can be tested. This is the package L uses to test itself. =head1 USE Test2::Suite INSTEAD Use L if at all possible. =head1 EXPORTS =over 4 =item ok($bool, $name) =item ok($bool, $name, @diag) Run a simple assertion. =item is($got, $want, $name) =item is($got, $want, $name, @diag) Assert that 2 strings are the same. =item isnt($got, $do_not_want, $name) =item isnt($got, $do_not_want, $name, @diag) Assert that 2 strings are not the same. =item like($got, $regex, $name) =item like($got, $regex, $name, @diag) Check that the input string matches the regex. =item unlike($got, $regex, $name) =item unlike($got, $regex, $name, @diag) Check that the input string does not match the regex. =item is_deeply($got, $want, $name) =item is_deeply($got, $want, $name, @diag) Check 2 data structures. Please note that this is a I implementation that compares the output of L against both structures. =item diag($msg) Issue a diagnostics message to STDERR. =item note($msg) Issue a diagnostics message to STDOUT. =item skip_all($reason) Skip all tests. =item todo $reason => sub { ... } Run a block in TODO mode. =item plan($count) Set the plan. =item done_testing() Set the plan to the current test count. =item $warnings = warnings { ... } Capture an arrayref of warnings from the block. =item $exception = exception { ... } Capture an exception. =item tests $name => sub { ... } Run a subtest. =item $output = capture { ... } Capture STDOUT and STDERR output. Result looks like this: { STDOUT => "...", STDERR => "...", } =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Spec.pm100644001750001750 4044714772042322 20645 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Spec; use strict; use warnings; our $VERSION = '1.302210'; 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(); our (@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 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 IPC000755001750001750 014772042322 16537 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Driver.pm100644001750001750 1456714772042322 20525 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/IPCpackage Test2::IPC::Driver; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/confess/; use Test2::Util::HashBase qw{no_fatal no_bail}; use Test2::API qw/test2_ipc_add_driver/; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; test2_ipc_add_driver($class); } sub pending { -1 } sub set_pending { -1 } for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { no strict 'refs'; *$meth = sub { my $thing = shift; confess "'$thing' did not define the required method '$meth'." }; } # Print the error and call exit. We are not using 'die' cause this is a # catastrophic error that should never be caught. If we get here it # means some serious shit has happened in a child process, the only way # to inform the parent may be to exit false. sub abort { my $self = shift; chomp(my ($msg) = @_); $self->driver_abort($msg) if $self->can('driver_abort'); print STDERR "IPC Fatal Error: $msg\n"; print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail; CORE::exit(255) unless $self->no_fatal; } sub abort_trace { my $self = shift; my ($msg) = @_; # Older versions of Carp do not export longmess() function, so it needs to be called with package name $self->abort(Carp::longmess($msg)); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver - Base class for Test2 IPC drivers. =head1 SYNOPSIS package Test2::IPC::Driver::MyDriver; use base 'Test2::IPC::Driver'; ... =head1 METHODS =over 4 =item $self->abort($msg) If an IPC encounters a fatal error it should use this. This will print the message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will forcefully exit 255. IPC errors may occur in threads or processes other than the main one, this method provides the best chance of the harness noticing the error. =item $self->abort_trace($msg) This is the same as C<< $ipc->abort($msg) >> except that it uses C to add a stack trace to the message. =back =head1 LOADING DRIVERS Test2::IPC::Driver has an C method. All drivers inherit this import method. This import method registers the driver. In most cases you just need to load the desired IPC driver to make it work. You should load this driver as early as possible. A warning will be issued if you load it too late for it to be effective. use Test2::IPC::Driver::MyDriver; ... =head1 WRITING DRIVERS package Test2::IPC::Driver::MyDriver; use strict; use warnings; use base 'Test2::IPC::Driver'; sub is_viable { return 0 if $^O eq 'win32'; # Will not work on windows. return 1; } sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } sub send { my $self = shift; my ($hid, $e, $global) = @_; ... # Send the event to the proper hub. # This may notify other procs/threads that there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } 1; =head2 METHODS SUBCLASSES MUST IMPLEMENT =over 4 =item $ipc->is_viable This should return true if the driver works in the current environment. This should return false if it does not. This is a CLASS method. =item $ipc->add_hub($hid) This is used to alert the driver that a new hub is expecting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it. sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } =item $ipc->drop_hub($hid) This is used to alert the driver that a hub is no longer accepting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it (This is the drivers responsibility to enforce). sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } =item $ipc->send($hid, $event); =item $ipc->send($hid, $event, $global); Used to send events from the current process/thread to the specified hub in its process+thread. sub send { my $self = shift; my ($hid, $e) = @_; ... # Send the event to the proper hub. # This may notify other procs/threads that there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } If C<$global> is true then the driver should send the event to all hubs in all processes and threads. =item @events = $ipc->cull($hid) Used to collect events that have been sent to the specified hub. sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } =item $ipc->waiting() This is called in the parent process when it is complete and waiting for all child processes and threads to complete. sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } =back =head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE =over 4 =item $ipc->driver_abort($msg) This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your chance to cleanup when an abort happens. You cannot prevent the abort, but you can gracefully except it. =back =head1 SOURCE The source code repository for Test2 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 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 Class.t100644001750001750 1120214772042322 20776 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Event.t100644001750001750 73614772042322 20764 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Defer.t100644001750001750 1032714772042322 20765 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Basic.t100644001750001750 1532414772042322 20763 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Bundle000755001750001750 014772042322 17501 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesMore.t100644001750001750 53014772042322 20706 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Bundleuse 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__ Compare000755001750001750 014772042322 17656 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesRef.t100644001750001750 160014772042322 20714 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Set.t100644001750001750 1056614772042322 20766 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Bag.t100644001750001750 1001714772042322 20713 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Isa.t100644001750001750 550414772042322 20723 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Plugin000755001750001750 014772042322 17526 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesUTF8.t100644001750001750 204414772042322 20601 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Pluginuse 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; plan_no_plan.t100644001750001750 143214772042322 21011 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/LegacyBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; BEGIN { if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) { plan skip_all => "Won't work with t/TEST"; } } plan 'no_plan'; pass('Just testing'); ok(1, 'Testing again'); { my $warning = ''; local $SIG{__WARN__} = sub { $warning = join "", @_ }; SKIP: { skip 'Just testing skip with no_plan'; fail("So very failed"); } is( $warning, '', 'skip with no "how_many" ok with no_plan' ); $warning = ''; TODO: { todo_skip "Just testing todo_skip"; fail("Just testing todo"); die "todo_skip should prevent this"; pass("Again"); } is( $warning, '', 'skip with no "how_many" ok with no_plan' ); } BEGIN_use_ok.t100644001750001750 60414772042322 20522 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # [rt.cpan.org 28345] # # A use_ok() inside a BEGIN block lacking a plan would be silently ignored. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More; my $result; BEGIN { $result = use_ok("strict"); } ok( $result, "use_ok() ran" ); done_testing(2); thread_taint.t100644001750001750 17214772042322 20777 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w use Test::More tests => 1; ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' ); fork.t100644001750001750 231414772042322 21003 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w use strict; use warnings; # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD use Test2::Util qw/CAN_FORK/; BEGIN { unless(CAN_FORK) { require Test::More; Test::More->import(skip_all => "fork is not supported"); } } use IO::Pipe; use Test::Builder; use Test::More; plan 'skip_all' => "This test cannot be run with the current formatter" unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); plan 'tests' => 1; subtest 'fork within subtest' => sub { plan tests => 2; my $pipe = IO::Pipe->new; my $pid = fork; defined $pid or plan skip_all => "Fork not working"; if ($pid) { $pipe->reader; my $child_output = do { local $/ ; <$pipe> }; waitpid $pid, 0; is $?, 0, 'child exit status'; like $child_output, qr/^[\s#]+Child Done\s*\z/, 'child output'; } else { $pipe->writer; # Force all T::B output into the pipe, for the parent # builder as well as the current subtest builder. my $tb = Test::Builder->new; $tb->output($pipe); $tb->failure_output($pipe); $tb->todo_output($pipe); diag 'Child Done'; exit 0; } }; todo.t100644001750001750 1252614772042322 21035 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # Test todo subtests. # # A subtest in a todo context should have all of its diagnostic output # redirected to the todo output destination, but individual tests # within the subtest should not become todo tests themselves. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More; use Test::Builder; use Test::Builder::Tester; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; our %line; # Repeat each test for various combinations of the todo reason, # the mechanism by which it is set and $Level. our @test_combos; foreach my $level (1, 2, 3) { push @test_combos, ['$TODO', 'Reason', $level], ['todo_start', 'Reason', $level], ['todo_start', '', $level], ['todo_start', 0, $level]; } plan tests => 8 * @test_combos; sub test_subtest_in_todo { my ($name, $code, $want_out, $no_tests_run) = @_; my $xxx = $no_tests_run ? 'No tests run for subtest "xxx"' : 'xxx'; chomp $want_out; my @outlines = split /\n/, $want_out; foreach my $combo (@test_combos) { my ($set_via, $todo_reason, $level) = @$combo; test_out( map { my $x = $_; $x =~ s/\s+$//g; $x } "# Subtest: xxx", @outlines, "not ok 1 - $xxx # TODO $todo_reason", "# Failed (TODO) test '$xxx'", "# at $0 line $line{xxx}.", "not ok 2 - regular todo test # TODO $todo_reason", "# Failed (TODO) test 'regular todo test'", "# at $0 line $line{reg}.", ); { local $TODO = $set_via eq '$TODO' ? $todo_reason : undef; if ($set_via eq 'todo_start') { Test::Builder->new->todo_start($todo_reason); } subtest_at_level( 'xxx', $code, $level); BEGIN{ $line{xxx} = __LINE__ } ok 0, 'regular todo test'; BEGIN{ $line{reg} = __LINE__ } if ($set_via eq 'todo_start') { Test::Builder->new->todo_end; } } test_test("$name ($level), todo [$todo_reason] set via $set_via"); } } package Foo; # If several stack frames are in package 'main' then $Level # could be wrong and $main::TODO might still be found. Using # another package makes the tests more sensitive. sub main::subtest_at_level { my ($name, $code, $level) = @_; if ($level > 1) { local $Test::Builder::Level = $Test::Builder::Level + 1; main::subtest_at_level($name, $code, $level-1); } else { Test::Builder->new->subtest($name => $code); } } package main; test_subtest_in_todo("plan, no tests run", sub { plan tests => 2; }, < 17; ok 0, 'failme'; BEGIN { $line{fail2} = __LINE__ } }, <new->todo_start('Inner2'); ok 0, 'failing TODO b'; BEGIN{ $line{ftb} = __LINE__ } ok 1, 'unexpected pass b'; Test::Builder->new->todo_end; ok 0, 'inner test 3'; BEGIN{ $line{in3} = __LINE__ } }, <new; $tb->ok( !eval { $tb->subtest() } ); $tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); $tb->ok( !eval { $tb->subtest("foo") } ); $tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); my $foo; $tb->subtest('Arg passing', sub { $foo = shift; $tb->ok(1); }, 'foo'); $tb->is_eq($foo, 'foo'); $tb->done_testing(); carp.t100644001750001750 111314772042322 20660 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 3; use Test::Builder; my $tb = Test::Builder->create; sub foo { $tb->croak("foo") } sub bar { $tb->carp("bar") } eval { foo() }; is $@, sprintf "foo at %s line %s.\n", $0, __LINE__ - 1; eval { $tb->croak("this") }; is $@, sprintf "this at %s line %s.\n", $0, __LINE__ - 1; { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= join '', @_; }; bar(); is $warning, sprintf "bar at %s line %s.\n", $0, __LINE__ - 1; } regression000755001750001750 014772042322 17000 5ustar00exodistexodist000000000000Test-Simple-1.302210/t132-bool.t100644001750001750 246714772042322 20574 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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; 812-todo.t100644001750001750 121614772042322 20602 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Test2::API qw/intercept/; use Test::More; my @values = ( 0, # false but defined -> inconsistent 0.0, # false but defined -> inconsistent "0.0", # true -> TODO "this is why", # as expected ); for my $value (@values) { local $TODO = $value; my $x = defined($value) ? "\"$value\"" : 'UNDEF'; fail "Testing: $x"; } my $e = intercept { local $TODO = ""; fail "Testing: '\"\"'"; }; ok(!$e->[0]->effective_pass, "Test was not TODO when set to \"\""); like($e->[1]->message, qr/Failed test '/, "Did not add TODO to the diagnostics"); done_testing; Event.t100644001750001750 5207614772042322 20731 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event(); use Test2::EventFacet::Trace(); use Test2::Event::Generic; use Test2::API qw/context/; use Scalar::Util qw/reftype/; tests old_api => sub { { package My::MockEvent; use base 'Test2::Event'; use Test2::Util::HashBase qw/foo bar baz/; } ok(My::MockEvent->can($_), "Added $_ accessor") for qw/foo bar baz/; my $one = My::MockEvent->new(trace => 'fake'); ok(!$one->causes_fail, "Events do not cause failures by default"); ok(!$one->$_, "$_ is false by default") for qw/increments_count terminate global/; ok(!$one->get_meta('xxx'), "no meta-data associated for key 'xxx'"); $one->set_meta('xxx', '123'); is($one->meta('xxx'), '123', "got meta-data"); is($one->meta('xxx', '321'), '123', "did not use default"); is($one->meta('yyy', '1221'), '1221', "got the default"); is($one->meta('yyy'), '1221', "last call set the value to the default for future use"); is($one->summary, 'My::MockEvent', "Default summary is event package"); is($one->diagnostics, 0, "Not diagnostics by default"); }; tests deprecated => sub { my $e = Test2::Event->new(trace => Test2::EventFacet::Trace->new(frame => ['foo', 'foo.pl', 42], nested => 2, hid => 'maybe')); my $warnings = warnings { local $ENV{AUTHOR_TESTING} = 1; is($e->nested, 2, "Got nested from the trace"); is($e->in_subtest, 'maybe', "got hid from trace"); $e->trace->{nested} = 0; local $ENV{AUTHOR_TESTING} = 0; is($e->nested, 0, "Not nested"); is($e->in_subtest, undef, "Did not get hid"); }; is(@$warnings, 2, "got warnings once each"); like($warnings->[0], qr/Use of Test2::Event->nested\(\) is deprecated/, "Warned about deprecation"); like($warnings->[1], qr/Use of Test2::Event->in_subtest\(\) is deprecated/, "Warned about deprecation"); }; tests facet_data => sub { my $e = Test2::Event::Generic->new( causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, callback => undef, terminate => undef, global => undef, sets_plan => undef, summary => undef, facet_data => undef, ); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef, }, control => { has_callback => 0, terminate => undef, global => 0 }, }, "Facet data has control with only false values, and an about" ); $e->set_trace(Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42])); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef, }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, }, "Got a trace now" ); $e->set_causes_fail(1); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, errors => [ { tag => 'FAIL', details => 'Test2::Event::Generic', fail => 1, } ], }, "Got an error" ); $e->set_increments_count(1); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 0, details => 'Test2::Event::Generic', }, }, "Got an assert now" ); $e->set_causes_fail(0); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 0, terminate => undef, global => 0 }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, }, "Got a passing assert now" ); $e->set_global(1); $e->set_terminate(255); $e->set_callback(sub {1}); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, }, "control fields were altered" ); my $data; { no warnings 'once'; local *Test2::Event::Generic::subtest_id = sub { 123 }; $data = $e->facet_data; } is_deeply( $data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, parent => {hid => 123}, }, "Added parent" ); $e->set_meta('foo', {a => 1}); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, }, "Grabbed meta" ); $e->set_sets_plan([5]); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 1, terminate => 255, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 5 }, }, "Plan facet added" ); $e->set_terminate(undef); $e->set_sets_plan([0, SKIP => 'because']); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 1, terminate => 0, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 0, skip => 1, details => 'because' }, }, "Plan set terminate, skip, and details" ); $e->set_sets_plan([0, 'NO PLAN' => 'because']); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 1, terminate => undef, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 0, none => 1, details => 'because' }, }, "Plan does not set terminate, but sets 'none' and 'details'" ); $e->add_amnesty({tag => 'foo', details => 'bar'}); $e->add_amnesty({tag => 'baz', details => 'bat'}); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef }, control => { has_callback => 1, terminate => undef, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => { count => 0, none => 1, details => 'because' }, amnesty => [ { tag => 'foo', details => 'bar' }, { tag => 'baz', details => 'bat' }, ], }, "Amnesty added" ); $e = Test2::Event::Generic->new(); $e->set_diagnostics(1); $e->set_no_display(1); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => 1, }, control => { has_callback => 0, terminate => undef, global => 0, }, }, "No Info" ); $e->set_no_display(0); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', eid => $e->eid, no_display => undef, }, control => { has_callback => 0, terminate => undef, global => 0, }, info => [{ details => 'Test2::Event::Generic', tag => 'DIAG', debug => 1, }], }, "Got debug Info" ); $e->set_summary("foo bar baz"); is_deeply( $e->facet_data, { about => { package => 'Test2::Event::Generic', details => 'foo bar baz', eid => $e->eid, no_display => undef, }, control => { has_callback => 0, terminate => undef, global => 0, }, info => [{ details => 'foo bar baz', tag => 'DIAG', debug => 1, }], }, "Got debug Info with summary change" ); }; tests facets => sub { my $data = { about => { package => 'Test2::Event::Generic', details => 'Test2::Event::Generic', no_display => undef }, control => { has_callback => 1, terminate => undef, global => 1, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, assert => { no_debug => 1, pass => 1, details => 'Test2::Event::Generic', }, meta => {foo => {a => 1}}, plan => {count => 0, none => 1, details => 'because'}, parent => {hid => 123, children => []}, amnesty => [ {tag => 'foo', details => 'bar'}, {tag => 'baz', details => 'bat'}, ], info => [ { details => 'foo bar baz', tag => 'DIAG', debug => 1, } ], errors => [{ tag => 'FAIL', details => 'Test2::Event::Generic', fail => 1, }], }; my $e = Test2::Event::Generic->new(facet_data => $data); is_deeply( $e->facet_data, $e->facets, "Facets and facet_data have the same structure" ); my $facets = $e->facets; for my $key (sort keys %$facets) { my $type = "Test2::EventFacet::" . ucfirst($key); $type =~ s/s$//; my $val = $facets->{$key}; if ($type->is_list) { for my $f (@$val) { ok($f->isa('Test2::EventFacet'), "'$key' has a blessed facet"); ok($f->isa("$type"), "'$key' is a '$type'") or diag("$f"); } } else { ok($val->isa('Test2::EventFacet'), "'$key' has a blessed facet"); ok($val->isa($type), "'$key' is a '$type'"); } } }; tests common_facet_data => sub { my $e = Test2::Event::Generic->new( causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, callback => undef, terminate => undef, global => undef, sets_plan => undef, summary => undef, facet_data => undef, ); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', eid => $e->eid, }, }, "Facet data has an about" ); $e->set_trace(Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42])); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', eid => $e->eid, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, }, "Got a trace now" ); $e->set_meta('foo', {a => 1}); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', eid => $e->eid, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, meta => {foo => {a => 1}}, }, "Grabbed meta" ); $e->add_amnesty({tag => 'foo', details => 'bar'}); $e->add_amnesty({tag => 'baz', details => 'bat'}); is_deeply( $e->common_facet_data, { about => { package => 'Test2::Event::Generic', eid => $e->eid, }, trace => { frame => ['foo', 'foo.t', 42], pid => $$, tid => 0, }, meta => {foo => {a => 1}}, amnesty => [ {tag => 'foo', details => 'bar'}, {tag => 'baz', details => 'bat'}, ], }, "Amnesty added" ); }; tests related => sub { my $ctx = context(); my $ev_a = $ctx->build_ev2(about => {}); my $ev_b = $ctx->build_ev2(about => {}); $ctx->release; $ctx = context(); my $ev_c = $ctx->build_ev2(about => {}); $ctx->release; delete $ev_a->{trace}->{uuid}; delete $ev_b->{trace}->{uuid}; delete $ev_c->{trace}->{uuid}; ok($ev_a->related($ev_b), "Related as they were created with the same context (no uuid)"); ok(!$ev_a->related($ev_c), "Not related as they were created with a different context (no uuid)"); $ev_a->{trace}->{uuid} = 'xxx'; # Yes I know it is not valid. $ev_b->{trace}->{uuid} = 'yyy'; # Yes I know it is not valid. $ev_c->{trace}->{uuid} = 'xxx'; # Yes I know it is not valid. ok(!$ev_a->related($ev_b), "Not related, traces have different UUID's"); ok($ev_a->related($ev_c), "Related, traces have the same UUID's"); }; tests verify_facet_data => sub { my $ev1 = Test2::Event::V2->new( assert => { pass => 1 }, info => [{tag => 'NOTE', details => 'oops' }], 'a custom one' => {}, ); is_deeply( [$ev1->validate_facet_data], [], "No errors" ); my $ev2 = Test2::Event::V2->new( assert => [{ pass => 1 }], info => {tag => 'NOTE', details => 'oops' }, 'a custom one' => {}, ); my @errors = $ev2->validate_facet_data; is(@errors, 2, "Got 2 errors"); like($errors[0], qr/^Facet 'assert' should not be a list, but got a a list/, "Got a list for a non-list type"); like($errors[1], qr/^Facet 'info' should be a list, but got a single item/, "Got a single item when a list is needed"); @errors = $ev2->validate_facet_data(require_facet_class => 1); is(@errors, 3, "Got 3 errors"); is($errors[0], "Could not find a facet class for facet 'a custom one'", "Classes required"); like($errors[1], qr/^Facet 'assert' should not be a list, but got a a list/, "Got a list for a non-list type"); like($errors[2], qr/^Facet 'info' should be a list, but got a single item/, "Got a single item when a list is needed"); is_deeply( [Test2::Event->validate_facet_data($ev1->facet_data)], [], "No errors" ); @errors = Test2::Event->validate_facet_data($ev2->facet_data); is(@errors, 2, "Got 2 errors"); like($errors[0], qr/^Facet 'assert' should not be a list, but got a a list/, "Got a list for a non-list type"); like($errors[1], qr/^Facet 'info' should be a list, but got a single item/, "Got a single item when a list is needed"); @errors = Test2::Event->validate_facet_data($ev2->facet_data, require_facet_class => 1); is(@errors, 3, "Got 3 errors"); is($errors[0], "Could not find a facet class for facet 'a custom one'", "Classes required"); like($errors[1], qr/^Facet 'assert' should not be a list, but got a a list/, "Got a list for a non-list type"); like($errors[2], qr/^Facet 'info' should be a list, but got a single item/, "Got a single item when a list is needed"); }; done_testing; behavior000755001750001750 014772042322 17420 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2uuid.t100644001750001750 652614772042322 20724 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse Test2::Tools::Tiny; use Test2::API qw/test2_add_uuid_via context intercept/; my %CNT; test2_add_uuid_via(sub { my $type = shift; $CNT{$type} ||= 1; $type . '-' . $CNT{$type}++; }); my $events = intercept { ok(1, "pass"); sub { my $ctx = context(); ok(1, "pass"); ok(0, "fail"); $ctx->release; }->(); tests foo => sub { ok(1, "pass"); }; warnings { require Test::More; *subtest = \&Test::More::subtest; }; subtest(foo => sub { ok(1, "pass"); }); }; my $hub = Test2::API::test2_stack->top; is($hub->uuid, 'hub-1', "First hub got a uuid"); is($events->[0]->uuid, 'event-1', "First event gets first uuid"); is($events->[0]->trace->uuid, 'context-2', "First event has correct context"); is($events->[0]->trace->huuid, 'hub-2', "First event has correct hub"); is($events->[0]->facet_data->{about}->{uuid}, "event-1", "The UUID makes it to facet data"); is($events->[1]->uuid, 'event-2', "Second event gets correct uuid"); is($events->[1]->trace->uuid, 'context-3', "Second event has correct context"); is($events->[1]->trace->huuid, 'hub-2', "Second event has correct hub"); is($events->[2]->uuid, 'event-3', "Third event gets correct uuid"); is($events->[2]->trace->uuid, $events->[1]->trace->uuid, "Third event shares context with event 2"); is($events->[2]->trace->huuid, 'hub-2', "Third event has correct hub"); is($events->[3]->uuid, 'event-6', "subtest event gets correct uuid (not next)"); is($events->[3]->subtest_uuid, 'hub-3', "subtest event gets correct subtest-uuid (next hub uuid)"); is($events->[3]->trace->uuid, 'context-4', "subtest gets next sequential context"); is($events->[3]->trace->huuid, 'hub-2', "subtest event has correct hub"); is($events->[3]->subevents->[0]->uuid, 'event-4', "First subevent gets next event uuid"); is($events->[3]->subevents->[0]->trace->uuid, 'context-5', "First subevent has correct context"); is($events->[3]->subevents->[0]->trace->huuid, 'hub-3', "First subevent has correct hub uuid (subtest hub uuid)"); is($events->[3]->subevents->[1]->uuid, 'event-5', "Second subevent gets next event uuid"); is($events->[3]->subevents->[1]->trace->uuid, $events->[3]->trace->uuid, "Second subevent has same context as subtest itself"); is($events->[3]->subevents->[1]->trace->huuid, 'hub-3', "Second subevent has correct hub uuid (subtest hub uuid)"); is($events->[5]->uuid, 'event-10', "subtest event gets correct uuid (not next)"); is($events->[5]->subtest_uuid, 'hub-4', "subtest event gets correct subtest-uuid (next hub uuid)"); is($events->[5]->trace->uuid, 'context-8', "subtest gets next sequential context"); is($events->[5]->trace->huuid, 'hub-2', "subtest event has correct hub"); is($events->[5]->subevents->[0]->uuid, 'event-8', "First subevent gets next event uuid"); is($events->[5]->subevents->[0]->trace->uuid, 'context-10', "First subevent has correct context"); is($events->[5]->subevents->[0]->trace->huuid, 'hub-4', "First subevent has correct hub uuid (subtest hub uuid)"); is($events->[5]->subevents->[1]->uuid, 'event-9', "Second subevent gets next event uuid"); is($events->[5]->subevents->[1]->trace->uuid, $events->[5]->trace->uuid, "Second subevent has same context as subtest itself"); is($events->[5]->subevents->[1]->trace->huuid, 'hub-2', "Second subevent has correct hub uuid (subtest hub uuid)"); done_testing; Transition.pod100644001750001750 3225114772042322 21145 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2=pod =head1 NAME Test2::Transition - Transition notes when upgrading to Test2 =head1 DESCRIPTION This is where gotchas and breakages related to the Test2 upgrade are documented. The upgrade causes Test::Builder to defer to Test2 under the hood. This transition is mostly transparent, but there are a few cases that can trip you up. =head1 THINGS THAT BREAK This is the list of scenarios that break with the new internals. =head2 Test::Builder1.5/2 conditionals =head3 The Problem a few years back there were two attempts to upgrade/replace Test::Builder. Confusingly these were called Test::Builder2 and Test::Builder1.5, in that order. Many people put conditionals in their code to check the Test::Builder version number and adapt their code accordingly. The Test::Builder2/1.5 projects both died out. Now the conditional code people added has become a mine field. A vast majority of modules broken by Test2 fall into this category. =head3 The Fix The fix is to remove all Test::Builder1.5/2 related code. Either use the legacy Test::Builder API, or use Test2 directly. =head2 Replacing the Test::Builder singleton =head3 The Problem Some test modules would replace the Test::Builder singleton instance with their own instance or subclass. This was usually done to intercept or modify results as they happened. The Test::Builder singleton is now a simple compatibility wrapper around Test2. The Test::Builder singleton is no longer the central place for results. Many results bypass the Test::Builder singleton completely, which breaks and behavior intended when replacing the singleton. =head3 The Fix If you simply want to intercept all results instead of letting them go to TAP, you should look at the L docs and read about pushing a new hub onto the hub stack. Replacing the hub temporarily is now the correct way to intercept results. If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >> method exported by Test::More to watch events as they are fired. If you wish to modify results before they go to TAP look at the C<< Test2::Hub->filter() >> method. =head2 Directly Accessing Hash Elements =head3 The Problem Some modules look directly at hash keys on the Test::Builder singleton. The problem here is that the Test::Builder singleton no longer holds anything important. =head3 The Fix The fix is to use the API specified in L to look at or modify state as needed. =head2 Subtest indentation =head3 The Problem An early change, in fact the change that made Test2 an idea, was a change to the indentation of the subtest note. It was decided it would be more readable to outdent the subtest note instead of having it inline with the subtest: # subtest foo ok 1 - blah 1..1 ok 1 - subtest foo The old style indented the note: # subtest foo ok 1 - blah 1..1 ok 1 - subtest foo This breaks tests that do string comparison of TAP output. =head3 The Fix my $indent = $INC{'Test2/API.pm'} ? '' : ' '; is( $subtest_output, "${indent}# subtest foo", "Got subtest note" ); Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be expected. If it is not set, then the old Test::Builder is in use, indentation should be expected. =head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED This is a list of cpan modules that have been known to have been broken by the upgrade at one point. =head2 WORKS BUT TESTS WILL FAIL These modules still function correctly, but their test suites will not pass. If you already have these modules installed then you can continue to use them. If you are trying to install them after upgrading Test::Builder you will need to force installation, or bypass the broken tests. =over 4 =item Test::DBIx::Class::Schema This module has a test that appears to work around a Test::Builder bug. The bug appears to have been fixed by Test2, which means the workaround causes a failure. This can be easily updated, but nobody has done so yet. Known broken in versions: 1.0.9 and older =item Device::Chip Tests break due to subtest indentation. Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has been submitted to fix the issue. =back =head2 UPGRADE SUGGESTED These are modules that did not break, but had broken test suites that have since been fixed. =over 4 =item Test::Exception Old versions work fine, but have a minor test name behavior that breaks with Test2. Old versions will no longer install because of this. The latest version on CPAN will install just fine. Upgrading is not required, but is recommended. Fixed in version: 0.43 =item Data::Peek Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch was applied to correct things that changed. The module itself works fine, there is no need to upgrade. Fixed in version: 0.45 =item circular::require Some tests were fragile and required base.pm to be loaded at a late stage. Test2 was loading base.pm too early. The tests were updated to fix this. The module itself never broke, you do not need to upgrade. Fixed in version: 0.12 =item Test::Module::Used A test worked around a now-fixed planning bug. There is no need to upgrade if you have an old version installed. New versions install fine if you want them. Fixed in version: 0.2.5 =item Test::Moose::More Some tests were fragile, but have been fixed. The actual breakage was from the subtest comment indentation change. No need to upgrade, old versions work fine. Only new versions will install. Fixed in version: 0.025 =item Test::FITesque This was broken by a bugfix to how planning is done. The test was updated after the bugfix. Fixed in version: 0.04 =item Test::Kit Old versions work fine, but would not install because L was in the dependency chain. An upgrade should not be needed. Fixed in version: 2.15 =item autouse A test broke because it depended on Scalar::Util not being loaded. Test2 loads Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's load status. There is no need to upgrade if you already have it installed. Fixed in version: 1.11 =back =head2 NEED TO UPGRADE =over 4 =item Test::SharedFork Old versions need to directly access Test::Builder singleton hash elements. The latest version on CPAN will still do this on old Test::Builder, but will defer to L on Test2. Fixed in version: 0.35 =item Test::Builder::Clutch This works by doing overriding methods on the singleton, and directly accessing hash values on the singleton. A new version has been released that uses the Test2 API to accomplish the same result in a saner way. Fixed in version: 0.07 =item Test::Dist::VersionSync This had Test::Builder2 conditionals. This was fixed by removing the conditionals. Fixed in version: 1.1.4 =item Test::Modern This relied on C<< Test::Builder->_try() >> which was a private method, documented as something nobody should use. This was fixed by using a different tool. Fixed in version: 0.012 =item Test::UseAllModules Version 0.14 relied on C<< Test::Builder->history >> which was available in Test::Builder 1.5. Versions 0.12 and 0.13 relied on other Test::Builder internals. Fixed in version: 0.15 =item Test::More::Prefix Worked by applying a role that wrapped C<< Test::Builder->_print_comment >>. Fixed by adding an event filter that modifies the message instead when running under Test2. Fixed in version: 0.007 =back =head2 STILL BROKEN =over 4 =item Test::Aggregate This distribution directly accesses the hash keys in the L singleton. It also approaches the problem from the wrong angle, please consider using L for similar functionality and L which allows module preloading at the harness level. Still broken as of version: 0.373 =item Test::Wrapper This module directly uses hash keys in the L singleton. This module is also obsolete thanks to the benefits of L. Use C from L to achieve a similar result. Still broken as of version: 0.3.0 =item Test::ParallelSubtest This module overrides C and C. It also directly accesses hash elements of the singleton. It has not yet been fixed. Alternatives: L and L (not stable). Still broken as of version: 0.05 =item Test::Pretty See L The author admits the module is crazy, and he is awaiting a stable release of something new (Test2) to completely rewrite it in a sane way. Still broken as of version: 0.32 =item Net::BitTorrent The tests for this module directly access L hash keys. Most, if not all of these hash keys have public API methods that could be used instead to avoid the problem. Still broken in version: 0.052 =item Test::Group It monkeypatches Test::Builder, and calls it "black magic" in the code. Still broken as of version: 0.20 =item Test::Flatten This modifies the Test::Builder internals in many ways. A better was to accomplish the goal of this module is to write your own subtest function. Still broken as of version: 0.11 =item Log::Dispatch::Config::TestLog Modifies Test::Builder internals. Still broken as of version: 0.02 =item Test::Able Modifies Test::Builder internals. Still broken as of version: 0.11 =back =head1 MAKE ASSERTIONS -> SEND EVENTS =head2 LEGACY use Test::Builder; # A majority of tools out there do this: # my $TB = Test::Builder->new; # This works, but has always been wrong, forcing Test::Builder to implement # subtests as a horrific hack. It also causes problems for tools that try # to replace the singleton (also discouraged). sub my_ok($;$) { my ($bool, $name) = @_; my $TB = Test::Builder->new; $TB->ok($bool, $name); } sub my_diag($) { my ($msg) = @_; my $TB = Test::Builder->new; $TB->diag($msg); } =head2 TEST2 use Test2::API qw/context/; sub my_ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } sub my_diag($) { my ($msg) = @_; my $ctx = context(); $ctx->diag($msg); $ctx->release; } The context object has API compatible implementations of the following methods: =over 4 =item ok($bool, $name) =item diag(@messages) =item note(@messages) =item subtest($name, $code) =back If you are looking for helpers with C, C, and others, see L. =head1 WRAP EXISTING TOOLS =head2 LEGACY use Test::More; sub exclusive_ok { my ($bool1, $bool2, $name) = @_; # Ensure errors are reported 1 level higher local $Test::Builder::Level = $Test::Builder::Level + 1; $ok = $bool1 || $bool2; $ok &&= !($bool1 && $bool2); ok($ok, $name); return $bool; } Every single tool in the chain from this, to C, to anything C calls needs to increment the C<$Level> variable. When an error occurs Test::Builder will do a trace to the stack frame determined by C<$Level>, and report that file+line as the one where the error occurred. If you or any other tool you use forgets to set C<$Level> then errors will be reported to the wrong place. =head2 TEST2 use Test::More; sub exclusive_ok { my ($bool1, $bool2, $name) = @_; # Grab and store the context, even if you do not need to use it # directly. my $ctx = context(); $ok = $bool1 || $bool2; $ok &&= !($bool1 && $bool2); ok($ok, $name); $ctx->release; return $bool; } Instead of using C<$Level> to perform a backtrace, Test2 uses a context object. In this sample you create a context object and store it. This locks the context (errors report 1 level up from here) for all wrapped tools to find. You do not need to use the context object, but you do need to store it in a variable. Once the sub ends the C<$ctx> variable is destroyed which lets future tools find their own. =head1 USING UTF8 =head2 LEGACY # Set the mode BEFORE anything loads Test::Builder use open ':std', ':encoding(utf8)'; use Test::More; Or # Modify the filehandles my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; binmode $builder->todo_output, ":encoding(utf8)"; =head2 TEST2 use Test2::API qw/test2_stack/; test2_stack->top->format->encoding('utf8'); Though a much better way is to use the L plugin, which is part of L. =head1 AUTHORS, CONTRIBUTORS AND REVIEWERS The following people have all contributed to this document in some way, even if only for review. =over 4 =item Chad Granum (EXODIST) Eexodist@cpan.orgE =back =head1 SOURCE The source code repository for Test2 can be found at L. =head1 MAINTAINER =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 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 Context.pm100644001750001750 6667514772042322 20723 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/APIpackage Test2::API::Context; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/confess croak/; use Scalar::Util qw/weaken blessed/; use Test2::Util qw/get_tid try pkg_to_file get_tid/; use Test2::EventFacet::Trace(); use Test2::API(); # Preload some key event types my %LOADED = ( map { my $pkg = "Test2::Event::$_"; my $file = "Test2/Event/$_.pm"; require $file unless $INC{$file}; ( $pkg => $pkg, $_ => $pkg ) } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail V2/ ); use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ stack hub trace _on_release _depth _is_canon _is_spawn _aborted errno eval_error child_error thrown _failed _start_fail_count }; # Private, not package vars # It is safe to cache these. my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); my $CONTEXTS = Test2::API::_contexts_ref(); sub init { my $self = shift; confess "The 'trace' attribute is required" unless $self->{+TRACE}; confess "The 'hub' attribute is required" unless $self->{+HUB}; $self->{+_START_FAIL_COUNT} = $self->{+HUB}->{failed} || 0; $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; $self->{+ERRNO} = $! unless exists $self->{+ERRNO}; $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; } sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } sub restore_error_vars { my $self = shift; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; } sub DESTROY { return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; my ($self) = @_; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; $self->{+_FAILED} = ($hub->{failed} || 0) - $self->{+_START_FAIL_COUNT}; # Do not show the warning if it looks like an exception has been thrown, or # if the context is not local to this process or thread. { # Sometimes $@ is uninitialized, not a problem in this case so do not # show the warning about using eq. no warnings 'uninitialized'; if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { require Carp; my $mess = Carp::longmess("Context destroyed"); my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; warn <<" EOT"; A context appears to have been destroyed without first calling release(). Based on \$@ it does not look like an exception was thrown (this is not always a reliable test) This is a problem because the global error variables (\$!, \$@, and \$?) will not be restored. In addition some release callbacks will not work properly from inside a DESTROY method. Here are the context creation details, just in case a tool forgot to call release(): File: $frame->[1] Line: $frame->[2] Tool: $frame->[3] Here is a trace to the code that caused the context to be destroyed, this could be an exit(), a goto, or simply the end of a scope: $mess Cleaning up the CONTEXT stack... EOT } } return if $self->{+_IS_SPAWN}; # Remove the key itself to avoid a slow memory leak delete $CONTEXTS->{$hid}; $self->{+_IS_CANON} = undef; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; if (my @diags = Test2::API::test2_clear_pending_diags()) { if ($self->{+_FAILED} || ${$self->{+_ABORTED}}) { $self->diag($_) for @diags; } } } # release exists to implement behaviors like die-on-fail. In die-on-fail you # want to die after a failure, but only after diagnostics have been reported. # The ideal time for the die to happen is when the context is released. # Unfortunately die does not work in a DESTROY block. sub release { my ($self) = @_; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN}; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef if $self->{+_IS_SPAWN}; croak "release() should not be called on context that is neither canon nor a child" unless $self->{+_IS_CANON}; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; $self->{+_FAILED} = ($hub->{failed} || 0) - $self->{+_START_FAIL_COUNT}; croak "context thinks it is canon, but it is not" unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; # Remove the key itself to avoid a slow memory leak $self->{+_IS_CANON} = undef; delete $CONTEXTS->{$hid}; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; if (my @diags = Test2::API::test2_clear_pending_diags()) { if ($self->{+_FAILED} || ${$self->{+_ABORTED}}) { $self->diag($_) for @diags; } } # Do this last so that nothing else changes them. # If one of the hooks dies then these do not get restored, this is # intentional ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; return; } sub do_in_context { my $self = shift; my ($sub, @args) = @_; # We need to update the pid/tid and error vars. my $clone = $self->snapshot; @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); $clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid()); my $hub = $clone->{+HUB}; my $hid = $hub->hid; my $old = $CONTEXTS->{$hid}; $clone->{+_IS_CANON} = 1; $CONTEXTS->{$hid} = $clone; weaken($CONTEXTS->{$hid}); my ($ok, $err) = &try($sub, @args); my ($rok, $rerr) = try { $clone->release }; delete $clone->{+_IS_CANON}; if ($old) { $CONTEXTS->{$hid} = $old; weaken($CONTEXTS->{$hid}); } else { delete $CONTEXTS->{$hid}; } die $err unless $ok; die $rerr unless $rok; } sub done_testing { my $self = shift; $self->hub->finalize($self->trace, 1); return; } sub throw { my ($self, $msg) = @_; $self->{+THROWN} = 1; ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; $self->trace->throw($msg); } sub alert { my ($self, $msg) = @_; $self->trace->alert($msg); } sub send_ev2_and_release { my $self = shift; my $out = $self->send_ev2(@_); $self->release; return $out; } sub send_ev2 { my $self = shift; my $e; { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $e = Test2::Event::V2->new( trace => $self->{+TRACE}->snapshot, @_, ); } if ($self->{+_ABORTED}) { my $f = $e->facet_data; ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); } $self->{+HUB}->send($e); } sub build_ev2 { my $self = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; Test2::Event::V2->new( trace => $self->{+TRACE}->snapshot, @_, ); } sub send_event_and_release { my $self = shift; my $out = $self->send_event(@_); $self->release; return $out; } sub send_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); my $e; { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $e = $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } if ($self->{+_ABORTED}) { my $f = $e->facet_data; ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); } $self->{+HUB}->send($e); } sub build_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); local $Carp::CarpLevel = $Carp::CarpLevel + 1; $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } sub pass { my $self = shift; my ($name) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Pass" ); $self->{+HUB}->send($e); return $e; } sub pass_and_release { my $self = shift; my ($name) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Pass" ); $self->{+HUB}->send($e); $self->release; return 1; } sub fail { my $self = shift; my ($name, @diag) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Fail" ); for my $msg (@diag) { if (ref($msg) eq 'Test2::EventFacet::Info::Table') { $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); } else { $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); } } $self->{+HUB}->send($e); return $e; } sub fail_and_release { my $self = shift; my ($name, @diag) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Fail" ); for my $msg (@diag) { if (ref($msg) eq 'Test2::EventFacet::Info::Table') { $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); } else { $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); } } $self->{+HUB}->send($e); $self->release; return 0; } sub ok { my $self = shift; my ($pass, $name, $on_fail) = @_; my $hub = $self->{+HUB}; my $e = bless { trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), pass => $pass, name => $name, }, 'Test2::Event::Ok'; $e->init; $hub->send($e); return $e if $pass; $self->failure_diag($e); if ($on_fail && @$on_fail) { $self->diag($_) for @$on_fail; } return $e; } sub failure_diag { my $self = shift; my ($e) = @_; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $e->name; my $trace = $e->trace; my $debug = $trace ? $trace->debug : "[No trace info available]"; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[Failed test '$name'\n$debug.\n] : qq[Failed test $debug.\n]; $self->diag($msg); } sub skip { my $self = shift; my ($name, $reason, @extra) = @_; $self->send_event( 'Skip', name => $name, reason => $reason, pass => 1, @extra, ); } sub note { my $self = shift; my ($message) = @_; $self->send_event('Note', message => $message); } sub diag { my $self = shift; my ($message) = @_; $self->send_event( 'Diag', message => $message, ); } sub plan { my ($self, $max, $directive, $reason) = @_; $self->send_event('Plan', max => $max, directive => $directive, reason => $reason); } sub bail { my ($self, $reason) = @_; $self->send_event('Bail', reason => $reason); } sub _parse_event { my $self = shift; my $event = shift; my $pkg; if ($event =~ m/^\+(.*)/) { $pkg = $1; } else { $pkg = "Test2::Event::$event"; } unless ($LOADED{$pkg}) { my $file = pkg_to_file($pkg); my ($ok, $err) = try { require $file }; $self->throw("Could not load event module '$pkg': $err") unless $ok; $LOADED{$pkg} = $pkg; } confess "'$pkg' is not a subclass of 'Test2::Event'" unless $pkg->isa('Test2::Event'); $LOADED{$event} = $pkg; return $pkg; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Context - Object to represent a testing context. =head1 DESCRIPTION The context object is the primary interface for authors of testing tools written with L. The context object represents the context in which a test takes place (File and Line Number), and provides a quick way to generate events from that context. The context object also takes care of sending events to the correct L instance. =head1 SYNOPSIS In general you will not be creating contexts directly. To obtain a context you should always use C which is exported by the L module. use Test2::API qw/context/; sub my_ok { my ($bool, $name) = @_; my $ctx = context(); if ($bool) { $ctx->pass($name); } else { $ctx->fail($name); } $ctx->release; # You MUST do this! return $bool; } Context objects make it easy to wrap other tools that also use context. Once you grab a context, any tool you call before releasing your context will inherit it: sub wrapper { my ($bool, $name) = @_; my $ctx = context(); $ctx->diag("wrapping my_ok"); my $out = my_ok($bool, $name); $ctx->release; # You MUST do this! return $out; } =head1 CRITICAL DETAILS =over 4 =item you MUST always use the context() sub from Test2::API Creating your own context via C<< Test2::API::Context->new() >> will almost never produce a desirable result. Use C which is exported by L. There are a handful of cases where a tool author may want to create a new context by hand, which is why the C method exists. Unless you really know what you are doing you should avoid this. =item You MUST always release the context when done with it Releasing the context tells the system you are done with it. This gives it a chance to run any necessary callbacks or cleanup tasks. If you forget to release the context it will try to detect the problem and warn you about it. =item You MUST NOT pass context objects around When you obtain a context object it is made specifically for your tool and any tools nested within. If you pass a context around you run the risk of polluting other tools with incorrect context information. If you are certain that you want a different tool to use the same context you may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. =item You MUST NOT store or cache a context for later As long as a context exists for a given hub, all tools that try to get a context will get the existing instance. If you try to store the context you will pollute other tools with incorrect context information. If you are certain that you want to save the context for later, you can use a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. C has some mechanisms to protect you if you do cause a context to persist beyond the scope in which it was obtained. In practice you should not rely on these protections, and they are fairly noisy with warnings. =item You SHOULD obtain your context as soon as possible in a given tool You never know what tools you call from within your own tool will need a context. Obtaining the context early ensures that nested tools can find the context you want them to find. =back =head1 METHODS =over 4 =item $ctx->done_testing; Note that testing is finished. If no plan has been set this will generate a Plan event. =item $clone = $ctx->snapshot() This will return a shallow clone of the context. The shallow clone is safe to store for later. =item $ctx->release() This will release the context. This runs cleanup tasks, and several important hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the context was created. B If a context is acquired more than once an internal refcount is kept. C decrements the ref count, none of the other actions of C will occur unless the refcount hits 0. This means only the last call to C will reset C<$?>, C<$!>, C<$@>, and run the cleanup tasks. =item $ctx->throw($message) This will throw an exception reporting to the file and line number of the context. This will also release the context for you. =item $ctx->alert($message) This will issue a warning from the file and line number of the context. =item $stack = $ctx->stack() This will return the L instance the context used to find the current hub. =item $hub = $ctx->hub() This will return the L instance the context recognizes as the current one to which all events should be sent. =item $dbg = $ctx->trace() This will return the L instance used by the context. =item $ctx->do_in_context(\&code, @args); Sometimes you have a context that is not current, and you want things to use it as the current one. In these cases you can call C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and anything inside of it that looks for a context will find the one on which the method was called. This B affect context on other hubs, only the hub used by the context will be affected. my $ctx = ...; $ctx->do_in_context(sub { my $ctx = context(); # returns the $ctx the sub is called on }); B The context will actually be cloned, the clone will be used instead of the original. This allows the thread id, process id, and error variables to be correct without modifying the original context. =item $ctx->restore_error_vars() This will set C<$!>, C<$?>, and C<$@> to what they were when the context was created. There is no localization or anything done here, calling this method will actually set these vars. =item $! = $ctx->errno() The (numeric) value of C<$!> when the context was created. =item $? = $ctx->child_error() The value of C<$?> when the context was created. =item $@ = $ctx->eval_error() The value of C<$@> when the context was created. =back =head2 EVENT PRODUCTION METHODS B The C and C are optimal if they meet your situation, using one of them will always be the most optimal. That said they are optimal by eliminating many features. Method such as C, and C are shortcuts for generating common 1-task events based on the old API, however they are forward compatible, and easy to use. If these meet your needs then go ahead and use them, but please check back often for alternatives that may be added. If you want to generate new style events, events that do many things at once, then you want the C<*ev2*> methods. These let you directly specify which facets you wish to use. =over 4 =item $event = $ctx->pass() =item $event = $ctx->pass($name) This will send and return an L event. You may optionally provide a C<$name> for the assertion. The L is a specially crafted and optimized event, using this will help the performance of passing tests. =item $true = $ctx->pass_and_release() =item $true = $ctx->pass_and_release($name) This is a combination of C and C. You can use this if you do not plan to do anything with the context after sending the event. This helps write more clear and compact code. sub shorthand { my ($bool, $name) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; ... Handle a failure ... } sub longform { my ($bool, $name) = @_; my $ctx = context(); if ($bool) { $ctx->pass($name); $ctx->release; return 1; } ... Handle a failure ... } =item my $event = $ctx->fail() =item my $event = $ctx->fail($name) =item my $event = $ctx->fail($name, @diagnostics) This lets you send an L event. You may optionally provide a C<$name> and C<@diagnostics> messages. Diagnostics messages can be simple strings, data structures, or instances of L (which are converted inline into the L structure). =item my $false = $ctx->fail_and_release() =item my $false = $ctx->fail_and_release($name) =item my $false = $ctx->fail_and_release($name, @diagnostics) This is a combination of C and C. This can be used to write clearer and shorter code. sub shorthand { my ($bool, $name) = @_; my $ctx = context(); return $ctx->fail_and_release($name) unless $bool; ... Handle a success ... } sub longform { my ($bool, $name) = @_; my $ctx = context(); unless ($bool) { $ctx->pass($name); $ctx->release; return 1; } ... Handle a success ... } =item $event = $ctx->ok($bool, $name) =item $event = $ctx->ok($bool, $name, \@on_fail) B Use of this method is discouraged in favor of C and C which produce L and L events. These newer event types are faster and less crufty. This will create an L object for you. If C<$bool> is false then an L event will be sent as well with details about the failure. If you do not want automatic diagnostics you should use the C method directly. The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in the event of a test failure. Unlike with C these diagnostics must be plain strings, data structures are not supported. =item $event = $ctx->note($message) Send an L. This event prints a message to STDOUT. =item $event = $ctx->diag($message) Send an L. This event prints a message to STDERR. =item $event = $ctx->plan($max) =item $event = $ctx->plan(0, 'SKIP', $reason) This can be used to send an L event. This event usually takes either a number of tests you expect to run. Optionally you can set the expected count to 0 and give the 'SKIP' directive with a reason to cause all tests to be skipped. =item $event = $ctx->skip($name, $reason); Send an L event. =item $event = $ctx->bail($reason) This sends an L event. This event will completely terminate all testing. =item $event = $ctx->send_ev2(%facets) This lets you build and send a V2 event directly from facets. The event is returned after it is sent. This example sends a single assertion, a note (comment for stdout in Test::Builder talk) and sets the plan to 1. my $event = $ctx->send_event( plan => {count => 1}, assert => {pass => 1, details => "A passing assert"}, info => [{tag => 'NOTE', details => "This is a note"}], ); =item $event = $ctx->build_e2(%facets) This is the same as C, except it builds and returns the event without sending it. =item $event = $ctx->send_ev2_and_release($Type, %parameters) This is a combination of C and C. sub shorthand { my $ctx = context(); return $ctx->send_ev2_and_release(assert => {pass => 1, details => 'foo'}); } sub longform { my $ctx = context(); my $event = $ctx->send_ev2(assert => {pass => 1, details => 'foo'}); $ctx->release; return $event; } =item $event = $ctx->send_event($Type, %parameters) B This lets you build and send an event of any type. The C<$Type> argument should be the event package name with C left off, or a fully qualified package name prefixed with a '+'. The event is returned after it is sent. my $event = $ctx->send_event('Ok', ...); or my $event = $ctx->send_event('+Test2::Event::Ok', ...); =item $event = $ctx->build_event($Type, %parameters) B This is the same as C, except it builds and returns the event without sending it. =item $event = $ctx->send_event_and_release($Type, %parameters) B This is a combination of C and C. sub shorthand { my $ctx = context(); return $ctx->send_event_and_release(Pass => { name => 'foo' }); } sub longform { my $ctx = context(); my $event = $ctx->send_event(Pass => { name => 'foo' }); $ctx->release; return $event; } =back =head1 HOOKS There are 2 types of hooks, init hooks, and release hooks. As the names suggest, these hooks are triggered when contexts are created or released. =head2 INIT HOOKS These are called whenever a context is initialized. That means when a new instance is created. These hooks are B called every time something requests a context, just when a new one is created. =head3 GLOBAL This is how you add a global init callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_init(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add an init callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_init(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you specify an init hook that will only run if your call to C generates a new context. The callback will be ignored if C is returning an existing context. my $ctx = context(on_init => sub { my $ctx = shift; ... }); =head2 RELEASE HOOKS These are called whenever a context is released. That means when the last reference to the instance is about to be destroyed. These hooks are B called every time C<< $ctx->release >> is called. =head3 GLOBAL This is how you add a global release callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_release(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add a release callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_release(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you add release callbacks directly to a context. The callback will B be added to the context that gets returned, it does not matter if a new one is generated, or if an existing one is returned. my $ctx = context(on_release => sub { my $ctx = shift; ... }); =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at L. =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 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 Class.pm100644001750001750 1135014772042322 21007 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Class; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Event.pm100644001750001750 332714772042322 21010 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Event; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Defer.pm100644001750001750 650214772042322 20752 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Defer; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Basic.pm100644001750001750 1571314772042322 20772 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Basic; use strict; use warnings; our $VERSION = '1.302210'; 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; return 0; } 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. Returns false, so as to preserve failure. =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 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 Bundle000755001750001750 014772042322 17335 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2More.pm100644001750001750 760314772042322 20743 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Bundlepackage Test2::Bundle::More; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Compare000755001750001750 014772042322 17512 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Set.pm100644001750001750 563114772042322 20750 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Set; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Isa.pm100644001750001750 321614772042322 20726 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Isa; use strict; use warnings; use Carp qw/confess/; use Scalar::Util qw/blessed/; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Ref.pm100644001750001750 364614772042322 20735 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Ref; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Bag.pm100644001750001750 1264114772042322 20725 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Bag; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Plugin000755001750001750 014772042322 17362 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2UTF8.pm100644001750001750 536414772042322 20616 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Pluginpackage Test2::Plugin::UTF8; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Hub000755001750001750 014772042322 16642 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Subtest.pm100644001750001750 511514772042322 20773 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Hubpackage Test2::Hub::Subtest; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; use Test2::Util qw/get_tid/; sub is_subtest { 1 } sub inherit { my $self = shift; my ($from) = @_; $self->SUPER::inherit($from); $self->{+NESTED} = $from->nested + 1; } { # Legacy no warnings 'once'; *ID = \&Test2::Hub::HID; *id = \&Test2::Hub::hid; *set_id = \&Test2::Hub::set_hid; } sub send { my $self = shift; my ($e) = @_; my $out = $self->SUPER::send($e); return $out if $self->{+MANUAL_SKIP_ALL}; my $f = $e->facet_data; my $plan = $f->{plan} or return $out; return $out unless $plan->{skip}; my $trace = $f->{trace} or die "Missing Trace!"; return $out unless $trace->{pid} != $self->pid || $trace->{tid} != $self->tid; no warnings 'exiting'; last T2_SUBTEST_WRAPPER; } sub terminate { my $self = shift; my ($code, $e, $f) = @_; $self->set_exit_code($code); return if $self->{+MANUAL_SKIP_ALL}; $f ||= $e->facet_data; if(my $plan = $f->{plan}) { my $trace = $f->{trace} or die "Missing Trace!"; return if $plan->{skip} && ($trace->{pid} != $$ || $trace->{tid} != get_tid); } no warnings 'exiting'; last T2_SUBTEST_WRAPPER; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Subtest - Hub used by subtests =head1 DESCRIPTION Subtests make use of this hub to route events. =head1 TOGGLES =over 4 =item $bool = $hub->manual_skip_all =item $hub->set_manual_skip_all($bool) The default is false. Normally a skip-all plan event will cause a subtest to stop executing. This is accomplished via C to a label inside the subtest code. Most of the time this is perfectly fine. There are times however where this flow control causes bad things to happen. This toggle lets you turn off the abort logic for the hub. When this is toggled to true B are responsible for ensuring no additional events are generated. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 AsyncSubtest.t100644001750001750 1356714772042322 21300 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesuse 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; Grabber.t100644001750001750 106014772042322 21073 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Utiluse 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; Tester.t100644001750001750 1032414772042322 21203 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Target.t100644001750001750 56614772042322 21132 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Base.t100644001750001750 261514772042322 21061 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Hash.t100644001750001750 1304614772042322 21112 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Bool.t100644001750001750 51714772042322 21061 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Meta.t100644001750001750 456414772042322 21102 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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-existent 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; Times.t100644001750001750 170714772042322 21141 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Pluginuse strict; use warnings; use Test2::API qw/intercept context/; use Test2::Tools::Defer qw/def do_def/; our @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(); SRand.t100644001750001750 550614772042322 21070 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Pluginuse 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{HARNESS_IS_VERBOSE} = 1; local $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"); $warning = like($warning, $reseed_qr, $reseed_name); my $hooks = Test2::API::test2_list_exit_callbacks(); delete $ENV{HARNESS_IS_VERBOSE}; $ENV{HARNESS_ACTIVE} = 1; $warning = warning { $events = intercept { $CLASS->import() } }; $warning = warning { $events = intercept { $CLASS->import() } }; is(Test2::API::test2_list_exit_callbacks, $hooks + 1, "added hook, but only once"); $warning = warning { $CLASS->import(undef) }; is($CLASS->seed, 0 , "set seed"); is($CLASS->from, 'import arg', "set from"); } done_testing(); Require000755001750001750 014772042322 17704 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesFork.t100644001750001750 77614772042322 21124 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse 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; Perl.t100644001750001750 33714772042322 21116 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse Test2::Bundle::Extended -target => 'Test2::Require::Perl'; is($CLASS->skip('v5.6'), undef, "will not skip"); is($CLASS->skip('v100.100'), 'Perl v100.100.0 required', "will skip"); # fix this before 2054 done_testing; async_trace.t100644001750001750 364514772042322 21247 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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__ circular_data.t100644001750001750 226014772042322 21146 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # Test is_deeply and friends with circular data structures [rt.cpan.org 7289] BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 11; my $a1 = [ 1, 2, 3 ]; push @$a1, $a1; my $a2 = [ 1, 2, 3 ]; push @$a2, $a2; is_deeply $a1, $a2; ok( eq_array ($a1, $a2) ); ok( eq_set ($a1, $a2) ); my $h1 = { 1=>1, 2=>2, 3=>3 }; $h1->{4} = $h1; my $h2 = { 1=>1, 2=>2, 3=>3 }; $h2->{4} = $h2; is_deeply $h1, $h2; ok( eq_hash ($h1, $h2) ); my ($r, $s); $r = \$r; $s = \$s; ok( eq_array ([$s], [$r]) ); { # Classic set of circular scalar refs. my($a,$b,$c); $a = \$b; $b = \$c; $c = \$a; my($d,$e,$f); $d = \$e; $e = \$f; $f = \$d; is_deeply( $a, $a ); is_deeply( $a, $d ); } { # rt.cpan.org 11623 # Make sure the circular ref checks don't get confused by a reference # which is simply repeating. my $a = {}; my $b = {}; my $c = {}; is_deeply( [$a, $a], [$b, $c] ); is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } ); is_deeply( [\$a, \$a], [\$b, \$c] ); } plan_skip_all.t100644001750001750 27614772042322 21146 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/LegacyBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; plan skip_all => 'Just testing plan & skip_all'; fail('We should never get here'); Test2000755001750001750 014772042322 17025 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/LegacySubtest.t100644001750001750 124714772042322 21007 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Test2use strict; use warnings; use Test::More; use Test2::API qw/intercept/; my $res = intercept { subtest foo => sub { ok(1, "check"); }; }; is(@$res, 2, "2 results"); isa_ok($res->[0], 'Test2::Event::Note'); is($res->[0]->message, 'Subtest: foo', "got subtest note"); isa_ok($res->[1], 'Test2::Event::Subtest'); ok($res->[1]->pass, "subtest passed"); my $subs = $res->[1]->subevents; is(@$subs, 2, "got all subevents"); isa_ok($subs->[0], 'Test2::Event::Ok'); is($subs->[0]->pass, 1, "subtest ok passed"); is($subs->[0]->name, 'check', "subtest ok name"); isa_ok($subs->[1], 'Test2::Event::Plan'); is($subs->[1]->max, 1, "subtest plan is 1"); done_testing; wstat.t100644001750001750 56114772042322 21166 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # Test that setting $? doesn't affect subtest success use strict; use Test::More; subtest foo => sub { plan tests => 1; $? = 1; pass('bar'); }; is $?, 1, "exit code keeps on from a subtest"; subtest foo2 => sub { plan tests => 1; pass('bar2'); $? = 1; }; is $?, 1, "exit code keeps on from a subtest"; done_testing(4); basic.t100644001750001750 1131414772042322 21143 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::Builder::NoOutput; use Test::More tests => 12; # TB Methods expect to be wrapped. my $ok = sub { shift->ok(@_) }; my $plan = sub { shift->plan(@_) }; my $diag = sub { shift->diag(@_) }; my $finalize = sub { shift->finalize(@_) }; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 7 ); for( 1 .. 3 ) { $tb->$ok( $_, "We're on $_" ); $tb->$diag("We ran $_"); } { my $indented = $tb->child; $indented->$plan('no_plan'); $indented->$ok( 1, "We're on 1" ); $indented->$ok( 1, "We're on 2" ); $indented->$ok( 1, "We're on 3" ); $indented->$finalize; } for( 7, 8, 9 ) { $tb->$ok( $_, "We're on $_" ); } is $tb->read, <<"END", 'Output should nest properly'; 1..7 ok 1 - We're on 1 # We ran 1 ok 2 - We're on 2 # We ran 2 ok 3 - We're on 3 # We ran 3 ok 1 - We're on 1 ok 2 - We're on 2 ok 3 - We're on 3 1..3 ok 4 - Child of $0 ok 5 - We're on 7 ok 6 - We're on 8 ok 7 - We're on 9 END } { my $tb = Test::Builder::NoOutput->create; $tb->$plan('no_plan'); for( 1 .. 1 ) { $tb->$ok( $_, "We're on $_" ); $tb->$diag("We ran $_"); } { my $indented = $tb->child; $indented->$plan('no_plan'); $indented->$ok( 1, "We're on 1" ); { my $indented2 = $indented->child('with name'); $indented2->$plan( tests => 2 ); $indented2->$ok( 1, "We're on 2.1" ); $indented2->$ok( 1, "We're on 2.1" ); $indented2->$finalize; } $indented->$ok( 1, 'after child' ); $indented->$finalize; } for(7) { $tb->$ok( $_, "We're on $_" ); } $tb->_ending; is $tb->read, <<"END", 'We should allow arbitrary nesting'; ok 1 - We're on 1 # We ran 1 ok 1 - We're on 1 1..2 ok 1 - We're on 2.1 ok 2 - We're on 2.1 ok 2 - with name ok 3 - after child 1..3 ok 2 - Child of $0 ok 3 - We're on 7 1..3 END } { #line 108 my $tb = Test::Builder::NoOutput->create; { my $child = $tb->child('expected to fail'); $child->$plan( tests => 3 ); $child->$ok(1); $child->$ok(0); $child->$ok(3); $child->$finalize; } { my $child = $tb->child('expected to pass'); $child->$plan( tests => 3 ); $child->$ok(1); $child->$ok(2); $child->$ok(3); $child->$finalize; } is $tb->read, <<"END", 'Previous child failures should not force subsequent failures'; 1..3 ok 1 not ok 2 # Failed test at $0 line 114. ok 3 # Looks like you failed 1 test of 3. not ok 1 - expected to fail # Failed test 'expected to fail' # at $0 line 116. 1..3 ok 1 ok 2 ok 3 ok 2 - expected to pass END } { my $tb = Test::Builder::NoOutput->create; my $child = $tb->child('one'); is $child->{$_}, $tb->{$_}, "The child should copy the ($_) filehandle" foreach qw{Out_FH Todo_FH Fail_FH}; $child->$finalize; } { my $tb = Test::Builder::NoOutput->create; my $child = $tb->child('one'); can_ok $child, 'parent'; can_ok $tb, 'name'; is $child->name, 'one', '... but child names should be whatever we set them to'; $child->$finalize; $child = $tb->child; $child->$finalize; } # Skip all subtests { my $tb = Test::Builder::NoOutput->create; { my $child = $tb->child('skippy says he loves you'); eval { $child->$plan( skip_all => 'cuz I said so' ) }; } subtest 'skip all', sub { plan skip_all => 'subtest with skip_all'; ok 0, 'This should never be run'; }; } # to do tests { #line 204 my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 1 ); my $child = $tb->child; $child->$plan( tests => 1 ); $child->todo_start( 'message' ); $child->$ok( 0 ); $child->todo_end; $child->$finalize; $tb->_ending; is $tb->read, <<"END", 'TODO tests should not make the parent test fail'; 1..1 1..1 not ok 1 # TODO message # Failed (TODO) test at $0 line 209. ok 1 - Child of $0 END } { my $tb = Test::Builder::NoOutput->create; $tb->$plan( tests => 1 ); my $child = $tb->child; $child->$finalize; $tb->_ending; my $expected = <<"END"; 1..1 not ok 1 - No tests run for subtest "Child of $0" END like $tb->read, qr/\Q$expected\E/, 'Not running subtests should make the parent test fail'; } reset.t100644001750001750 402414772042322 21061 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # HARNESS-NO-STREAM # Test Test::Builder->reset; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::Builder; my $Test = Test::Builder->new; my $tb = Test::Builder->create; # We'll need this later to know the outputs were reset my %Original_Output; $Original_Output{$_} = $tb->$_ for qw(output failure_output todo_output); # Alter the state of Test::Builder as much as possible. my $output = ''; $tb->output(\$output); $tb->failure_output(\$output); $tb->todo_output(\$output); $tb->plan(tests => 14); $tb->level(0); $tb->ok(1, "Running a test to alter TB's state"); # This won't print since we just sent output off to oblivion. $tb->ok(0, "And a failure for fun"); $Test::Builder::Level = 3; $tb->exported_to('Foofer'); $tb->use_numbers(0); $tb->no_header(1); $tb->no_ending(1); $tb->done_testing; # make sure done_testing gets reset # Now reset it. $tb->reset; # Test the state of the reset builder $Test->ok( !defined $tb->exported_to, 'exported_to' ); $Test->is_eq( $tb->expected_tests, 0, 'expected_tests' ); $Test->is_eq( $tb->level, 1, 'level' ); $Test->is_eq( $tb->use_numbers, 1, 'use_numbers' ); $Test->is_eq( $tb->no_header, 0, 'no_header' ); $Test->is_eq( $tb->no_ending, 0, 'no_ending' ); $Test->is_eq( $tb->current_test, 0, 'current_test' ); $Test->is_eq( scalar $tb->summary, 0, 'summary' ); $Test->is_eq( scalar $tb->details, 0, 'details' ); $Test->is_eq( fileno $tb->output, fileno $Original_Output{output}, 'output' ); $Test->is_eq( fileno $tb->failure_output, fileno $Original_Output{failure_output}, 'failure_output' ); $Test->is_eq( fileno $tb->todo_output, fileno $Original_Output{todo_output}, 'todo_output' ); # The reset Test::Builder will take over from here. $Test->no_ending(1); $tb->current_test($Test->current_test); $tb->level(0); $tb->ok(1, 'final test to make sure output was reset'); $tb->done_testing; is_fh.t100644001750001750 171714772042322 21035 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 11; use TieOut; ok( !Test::Builder->is_fh("foo"), 'string is not a filehandle' ); ok( !Test::Builder->is_fh(''), 'empty string' ); ok( !Test::Builder->is_fh(undef), 'undef' ); ok( open(FILE, '>foo') ); END { close FILE; 1 while unlink 'foo' } ok( Test::Builder->is_fh(*FILE) ); ok( Test::Builder->is_fh(\*FILE) ); ok( Test::Builder->is_fh(*FILE{IO}) ); tie *OUT, 'TieOut'; ok( Test::Builder->is_fh(*OUT) ); ok( Test::Builder->is_fh(\*OUT) ); SKIP: { skip "*TIED_HANDLE{IO} doesn't work in this perl", 1 unless defined *OUT{IO}; ok( Test::Builder->is_fh(*OUT{IO}) ); } package Lying::isa; sub isa { my $self = shift; my $parent = shift; return 1 if $parent eq 'IO::Handle'; } ::ok( Test::Builder->is_fh(bless {}, "Lying::isa")); utf8-mock.t100644001750001750 56314772042322 21126 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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; Taint.t100644001750001750 54414772042322 21007 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavior#!/usr/bin/env perl -T # HARNESS-NO-FORMATTER use Test2::API qw/context/; sub ok($;$@) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; return $bool ? 1 : 0; } sub done_testing { my $ctx = context(); $ctx->hub->finalize($ctx->trace, 1); $ctx->release; } ok(1); ok(1); done_testing; AsyncSubtest.pm100644001750001750 4611614772042322 21301 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2package Test2::AsyncSubtest; use strict; use warnings; use Test2::IPC; our $VERSION = '1.302210'; 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 affecting 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 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 Instance.pm100644001750001750 5235514772042322 21031 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/APIpackage Test2::API::Instance; use strict; use warnings; our $VERSION = '1.302210'; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; use Scalar::Util qw/reftype/; use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/; use Test2::EventFacet::Trace(); use Test2::API::Stack(); use Test2::Util::HashBase qw{ _pid _tid no_wait finalized loaded ipc stack formatter contexts add_uuid_via -preload ipc_disabled ipc_polling ipc_drivers ipc_timeout formatters exit_callbacks post_load_callbacks context_acquire_callbacks context_init_callbacks context_release_callbacks pre_subtest_callbacks trace_stamps }; sub DEFAULT_IPC_TIMEOUT() { 30 } sub test2_enable_trace_stamps { $_[0]->{+TRACE_STAMPS} = 1 } sub test2_disable_trace_stamps { $_[0]->{+TRACE_STAMPS} = 0 } sub test2_trace_stamps_enabled { $_[0]->{+TRACE_STAMPS} } sub pid { $_[0]->{+_PID} } sub tid { $_[0]->{+_TID} } # Wrap around the getters that should call _finalize. BEGIN { for my $finalizer (IPC, FORMATTER) { my $orig = __PACKAGE__->can($finalizer); my $new = sub { my $self = shift; $self->_finalize unless $self->{+FINALIZED}; $self->$orig; }; no strict 'refs'; no warnings 'redefine'; *{$finalizer} = $new; } } sub has_ipc { !!$_[0]->{+IPC} } sub import { my $class = shift; return unless @_; my ($ref) = @_; $$ref = $class->new; } sub init { $_[0]->reset } sub start_preload { my $self = shift; confess "preload cannot be started, Test2::API has already been initialized" if $self->{+FINALIZED} || $self->{+LOADED}; return $self->{+PRELOAD} = 1; } sub stop_preload { my $self = shift; return 0 unless $self->{+PRELOAD}; $self->{+PRELOAD} = 0; $self->post_preload_reset(); return 1; } sub post_preload_reset { my $self = shift; delete $self->{+_PID}; delete $self->{+_TID}; $self->{+ADD_UUID_VIA} = undef unless exists $self->{+ADD_UUID_VIA}; $self->{+CONTEXTS} = {}; $self->{+FORMATTERS} = []; $self->{+FINALIZED} = undef; $self->{+IPC} = undef; $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; $self->{+LOADED} = 0; $self->{+STACK} ||= Test2::API::Stack->new; } sub reset { my $self = shift; delete $self->{+_PID}; delete $self->{+_TID}; $self->{+TRACE_STAMPS} = $ENV{T2_TRACE_STAMPS} || 0; $self->{+ADD_UUID_VIA} = undef; $self->{+CONTEXTS} = {}; $self->{+IPC_DRIVERS} = []; $self->{+IPC_POLLING} = undef; $self->{+FORMATTERS} = []; $self->{+FORMATTER} = undef; $self->{+FINALIZED} = undef; $self->{+IPC} = undef; $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; $self->{+NO_WAIT} = 0; $self->{+LOADED} = 0; $self->{+EXIT_CALLBACKS} = []; $self->{+POST_LOAD_CALLBACKS} = []; $self->{+CONTEXT_ACQUIRE_CALLBACKS} = []; $self->{+CONTEXT_INIT_CALLBACKS} = []; $self->{+CONTEXT_RELEASE_CALLBACKS} = []; $self->{+PRE_SUBTEST_CALLBACKS} = []; $self->{+STACK} = Test2::API::Stack->new; } sub _finalize { my $self = shift; my ($caller) = @_; $caller ||= [caller(1)]; confess "Attempt to initialize Test2::API during preload" if $self->{+PRELOAD}; $self->{+FINALIZED} = $caller; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; unless ($self->{+FORMATTER}) { my ($formatter, $source); if ($ENV{T2_FORMATTER}) { $source = "set by the 'T2_FORMATTER' environment variable"; if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { $formatter = $1 ? $2 : "Test2::Formatter::$2" } else { $formatter = ''; } } elsif (@{$self->{+FORMATTERS}}) { ($formatter) = @{$self->{+FORMATTERS}}; $source = "Most recently added"; } else { $formatter = 'Test2::Formatter::TAP'; $source = 'default formatter'; } unless (ref($formatter) || $formatter->can('write')) { my $file = pkg_to_file($formatter); my ($ok, $err) = try { require $file }; unless ($ok) { my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *"; my $border = '*' x length($line); die "\n\n $border\n $line\n $border\n\n$err"; } } $self->{+FORMATTER} = $formatter; } # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC # module is loaded. return if $self->{+IPC_DISABLED}; return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}}; # Turn on polling by default, people expect it. $self->enable_ipc_polling; unless (@{$self->{+IPC_DRIVERS}}) { my ($ok, $error) = try { require Test2::IPC::Driver::Files }; die $error unless $ok; push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files'; } for my $driver (@{$self->{+IPC_DRIVERS}}) { next unless $driver->can('is_viable') && $driver->is_viable; $self->{+IPC} = $driver->new or next; return; } die "IPC has been requested, but no viable drivers were found. Aborting...\n"; } sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 } sub add_formatter { my $self = shift; my ($formatter) = @_; unshift @{$self->{+FORMATTERS}} => $formatter; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::Formatter'} = 1; carp "Formatter $formatter loaded too late to be used as the global formatter"; } sub add_context_acquire_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-acquire callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code; } sub add_context_init_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-init callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code; } sub add_context_release_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-release callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code; } sub add_post_load_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Post-load callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+POST_LOAD_CALLBACKS}} => $code; $code->() if $self->{+LOADED}; } sub add_pre_subtest_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Pre-subtest callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code; } sub load { my $self = shift; unless ($self->{+LOADED}) { confess "Attempt to initialize Test2::API during preload" if $self->{+PRELOAD}; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; # This is for https://github.com/Test-More/test-more/issues/16 # and https://rt.perl.org/Public/Bug/Display.html?id=127774 # END blocks run in reverse order. This insures the END block is loaded # as late as possible. It will not solve all cases, but it helps. eval "END { Test2::API::test2_set_is_end() }; 1" or die $@; $self->{+LOADED} = 1; $_->() for @{$self->{+POST_LOAD_CALLBACKS}}; } return $self->{+LOADED}; } sub add_exit_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "End callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+EXIT_CALLBACKS}} => $code; } sub ipc_disable { my $self = shift; confess "Attempt to disable IPC after it has been initialized" if $self->{+IPC}; $self->{+IPC_DISABLED} = 1; } sub add_ipc_driver { my $self = shift; my ($driver) = @_; unshift @{$self->{+IPC_DRIVERS}} => $driver; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::IPC::Driver'} = 1; carp "IPC driver $driver loaded too late to be used as the global ipc driver"; } sub enable_ipc_polling { my $self = shift; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; $self->add_context_init_callback( # This is called every time a context is created, it needs to be fast. # $_[0] is a context object sub { return unless $self->{+IPC_POLLING}; return unless $self->{+IPC}; return unless $self->{+IPC}->pending(); return $_[0]->{hub}->cull; } ) unless defined $self->ipc_polling; $self->set_ipc_polling(1); } sub get_ipc_pending { my $self = shift; return -1 unless $self->{+IPC}; $self->{+IPC}->pending(); } sub _check_pid { my $self = shift; my ($pid) = @_; return kill(0, $pid); } sub set_ipc_pending { my $self = shift; return unless $self->{+IPC}; my ($val) = @_; confess "value is required for set_ipc_pending" unless $val; $self->{+IPC}->set_pending($val); } sub disable_ipc_polling { my $self = shift; return unless defined $self->{+IPC_POLLING}; $self->{+IPC_POLLING} = 0; } sub _ipc_wait { my ($timeout) = @_; my $fail = 0; $timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout; my $ok = eval { if (CAN_FORK) { local $SIG{ALRM} = sub { die "Timeout waiting on child processes" }; alarm $timeout; while (1) { my $pid = CORE::wait(); my $err = $?; last if $pid == -1; next unless $err; $fail++; my $sig = $err & 127; my $exit = $err >> 8; warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n"; } alarm 0; } if (USE_THREADS) { my $start = time; while (1) { last unless threads->list(); die "Timeout waiting on child thread" if time - $start >= $timeout; sleep 1; for my $t (threads->list) { # threads older than 1.34 do not have this :-( next if $t->can('is_joinable') && !$t->is_joinable; $t->join; # In older threads we cannot check if a thread had an error unless # we control it and its return. my $err = $t->can('error') ? $t->error : undef; next unless $err; my $tid = $t->tid(); $fail++; chomp($err); warn "Thread $tid did not end cleanly: $err\n"; } } } 1; }; my $error = $@; return 0 if $ok && !$fail; warn $error unless $ok; return 255; } sub set_exit { my $self = shift; return if $self->{+PRELOAD}; my $exit = $?; my $new_exit = $exit; if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) { print STDERR <<" EOT"; ******************************************************************************** * * * Test::Builder -- Test2::API version mismatch detected * * * ******************************************************************************** Test2::API Version: $Test2::API::VERSION Test::Builder Version: $Test::Builder::VERSION This is not a supported configuration, you will have problems. EOT } for my $ctx (values %{$self->{+CONTEXTS}}) { next unless $ctx; next if $ctx->_aborted && ${$ctx->_aborted}; # Only worry about contexts in this PID my $trace = $ctx->trace || next; next unless $trace->pid && $trace->pid == $$; # Do not worry about contexts that have no hub my $hub = $ctx->hub || next; # Do not worry if the state came to a sudden end. next if $hub->bailed_out; next if defined $hub->skip_reason; # now we worry $trace->alert("context object was never released! This means a testing tool is behaving very badly"); $exit = 255; $new_exit = 255; } if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) { $? = $exit; return; } my @hubs = $self->{+STACK} ? $self->{+STACK}->all : (); if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) { local $?; my %seen; for my $hub (reverse @hubs) { my $ipc = $hub->ipc or next; next if $seen{$ipc}++; $ipc->waiting(); } my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT}); $new_exit ||= $ipc_exit; } # None of this is necessary if we never got a root hub if(my $root = shift @hubs) { my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], detail => __PACKAGE__ . ' END Block finalization', ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $root, ); if (@hubs) { $ctx->diag("Test ended with extra hubs on the stack!"); $new_exit = 255; } unless ($root->no_ending) { local $?; $root->finalize($trace) unless $root->ended; $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}}; $new_exit ||= $root->failed; $new_exit ||= 255 unless $root->is_passing; } } $new_exit = 255 if $new_exit > 255; if ($new_exit && eval { require Test2::API::Breakage; 1 }) { my @warn = Test2::API::Breakage->report(); if (@warn) { print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n"; print STDERR "$_\n" for @warn; print STDERR "\n"; } } $? = $new_exit; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Instance - Object used by Test2::API under the hood =head1 DESCRIPTION This object encapsulates the global shared state tracked by L. A single global instance of this package is stored (and obscured) by the L package. There is no reason to directly use this package. This package is documented for completeness. This package can change, or go away completely at any time. Directly using, or monkeypatching this package is not supported in any way shape or form. =head1 SYNOPSIS use Test2::API::Instance; my $obj = Test2::API::Instance->new; =over 4 =item $pid = $obj->pid PID of this instance. =item $obj->tid Thread ID of this instance. =item $obj->reset() Reset the object to defaults. =item $obj->load() Set the internal state to loaded, and run and stored post-load callbacks. =item $bool = $obj->loaded Check if the state is set to loaded. =item $arrayref = $obj->post_load_callbacks Get the post-load callbacks. =item $obj->add_post_load_callback(sub { ... }) Add a post-load callback. If C has already been called then the callback will be immediately executed. If C has not been called then the callback will be stored and executed later when C is called. =item $hashref = $obj->contexts() Get a hashref of all active contexts keyed by hub id. =item $arrayref = $obj->context_acquire_callbacks Get all context acquire callbacks. =item $arrayref = $obj->context_init_callbacks Get all context init callbacks. =item $arrayref = $obj->context_release_callbacks Get all context release callbacks. =item $arrayref = $obj->pre_subtest_callbacks Get all pre-subtest callbacks. =item $obj->add_context_init_callback(sub { ... }) Add a context init callback. Subs are called every time a context is created. Subs get the newly created context as their only argument. =item $obj->add_context_release_callback(sub { ... }) Add a context release callback. Subs are called every time a context is released. Subs get the released context as their only argument. These callbacks should not call release on the context. =item $obj->add_pre_subtest_callback(sub { ... }) Add a pre-subtest callback. Subs are called every time a subtest is going to be run. Subs get the subtest name, coderef, and any arguments. =item $obj->set_exit() This is intended to be called in an C block. This will look at test state and set $?. This will also call any end callbacks, and wait on child processes/threads. =item $obj->set_ipc_pending($val) Tell other processes and threads there is a pending event. C<$val> should be a unique value no other thread/process will generate. B This will also make the current process see a pending event. =item $pending = $obj->get_ipc_pending() This returns -1 if it is not possible to know. This returns 0 if there are no pending events. This returns 1 if there are pending events. =item $timeout = $obj->ipc_timeout; =item $obj->set_ipc_timeout($timeout); How long to wait for child processes and threads before aborting. =item $drivers = $obj->ipc_drivers Get the list of IPC drivers. =item $obj->add_ipc_driver($DRIVER_CLASS) Add an IPC driver to the list. The most recently added IPC driver will become the global one during initialization. If a driver is added after initialization has occurred a warning will be generated: "IPC driver $driver loaded too late to be used as the global ipc driver" =item $bool = $obj->ipc_polling Check if polling is enabled. =item $obj->enable_ipc_polling Turn on polling. This will cull events from other processes and threads every time a context is created. =item $obj->disable_ipc_polling Turn off IPC polling. =item $bool = $obj->no_wait =item $bool = $obj->set_no_wait($bool) Get/Set no_wait. This option is used to turn off process/thread waiting at exit. =item $arrayref = $obj->exit_callbacks Get the exit callbacks. =item $obj->add_exit_callback(sub { ... }) Add an exit callback. This callback will be called by C. =item $bool = $obj->finalized Check if the object is finalized. Finalization happens when either C, C, or C are called on the object. Once finalization happens these fields are considered unchangeable (not enforced here, enforced by L). =item $ipc = $obj->ipc Get the one true IPC instance. =item $obj->ipc_disable Turn IPC off =item $bool = $obj->ipc_disabled Check if IPC is disabled =item $stack = $obj->stack Get the one true hub stack. =item $formatter = $obj->formatter Get the global formatter. By default this is the C<'Test2::Formatter::TAP'> package. This could be any package that implements the C method. This can also be an instantiated object. =item $bool = $obj->formatter_set() Check if a formatter has been set. =item $obj->add_formatter($class) =item $obj->add_formatter($obj) Add a formatter. The most recently added formatter will become the global one during initialization. If a formatter is added after initialization has occurred a warning will be generated: "Formatter $formatter loaded too late to be used as the global formatter" =item $obj->set_add_uuid_via(sub { ... }) =item $sub = $obj->add_uuid_via() This allows you to provide a UUID generator. If provided UUIDs will be attached to all events, hubs, and contexts. This is useful for storing, tracking, and linking these objects. The sub you provide should always return a unique identifier. Most things will expect a proper UUID string, however nothing in Test2::API enforces this. The sub will receive exactly 1 argument, the type of thing being tagged 'context', 'hub', or 'event'. In the future additional things may be tagged, in which case new strings will be passed in. These are purely informative, you can (and usually should) ignore them. =back =head1 SOURCE The source code repository for Test2 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 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 Breakage.pm100644001750001750 1133014772042322 20752 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/APIpackage Test2::API::Breakage; use strict; use warnings; our $VERSION = '1.302210'; use Test2::Util qw/pkg_to_file/; our @EXPORT_OK = qw{ upgrade_suggested upgrade_required known_broken }; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub upgrade_suggested { return ( 'Test::Exception' => '0.42', 'Test::FITesque' => '0.04', 'Test::Module::Used' => '0.2.5', 'Test::Moose::More' => '0.025', ); } sub upgrade_required { return ( 'Test::Builder::Clutch' => '0.07', 'Test::Dist::VersionSync' => '1.1.4', 'Test::Modern' => '0.012', 'Test::SharedFork' => '0.34', 'Test::Alien' => '0.04', 'Test::UseAllModules' => '0.14', 'Test::More::Prefix' => '0.005', 'Test2::Tools::EventDumper' => 0.000007, 'Test2::Harness' => 0.000013, 'Test::DBIx::Class::Schema' => '1.0.9', 'Test::Clustericious::Cluster' => '0.30', ); } sub known_broken { return ( 'Net::BitTorrent' => '0.052', 'Test::Able' => '0.11', 'Test::Aggregate' => '0.373', 'Test::Flatten' => '0.11', 'Test::Group' => '0.20', 'Test::ParallelSubtest' => '0.05', 'Test::Pretty' => '0.32', 'Test::Wrapper' => '0.3.0', 'Log::Dispatch::Config::TestLog' => '0.02', ); } # Not reportable: # Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to. sub report { my $class = shift; my ($require) = @_; my %suggest = __PACKAGE__->upgrade_suggested(); my %required = __PACKAGE__->upgrade_required(); my %broken = __PACKAGE__->known_broken(); my @warn; for my $mod (keys %suggest) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $want = $suggest{$mod}; next if eval { $mod->VERSION($want); 1 }; my $error = $@; chomp $error; push @warn => " * Module '$mod' is outdated, we recommend updating above $want. error was: '$error'; INC is $INC{$file}"; } for my $mod (keys %required) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $want = $required{$mod}; next if eval { $mod->VERSION($want); 1 }; push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher."; } for my $mod (keys %broken) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $tested = $broken{$mod}; push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION; } return @warn; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Breakage - What breaks at what version =head1 DESCRIPTION This module provides lists of modules that are broken, or have been broken in the past, when upgrading L to use L. =head1 FUNCTIONS These can be imported, or called as methods on the class. =over 4 =item %mod_ver = upgrade_suggested() =item %mod_ver = Test2::API::Breakage->upgrade_suggested() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then an upgrade would be a good idea, but not strictly necessary. =item %mod_ver = upgrade_required() =item %mod_ver = Test2::API::Breakage->upgrade_required() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then an upgrade is required for the module to work properly. =item %mod_ver = known_broken() =item %mod_ver = Test2::API::Breakage->known_broken() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then the module will not work. A newer version may work, but is not tested or verified. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Grabber.pm100644001750001750 1305014772042322 21122 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Grabber; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Target.pm100644001750001750 375714772042322 21164 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Target; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Tester.pm100644001750001750 1702114772042322 21211 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Tester; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/croak/; use Test2::Util::Ref qw/rtype/; BEGIN { if (eval { no warnings 'deprecated'; 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 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 Meta.pm100644001750001750 667014772042322 21107 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Meta; use strict; use warnings; use Test2::Compare::Delta(); use Test2::Compare::Isa(); use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Base.pm100644001750001750 1314614772042322 21107 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Base; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Bool.pm100644001750001750 350514772042322 21106 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Bool; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Hash.pm100644001750001750 1336514772042322 21123 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Hash; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 SRand.pm100644001750001750 1061314772042322 21110 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Pluginpackage Test2::Plugin::SRand; use strict; use warnings; our $VERSION = '1.302210'; 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 CAVEATS When srand is on (default) it can cause problems with things like L which will end up attempting the same "random" filenames for every test process started on a given day (or sharing the same seed). =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 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 Times.pm100644001750001750 610414772042322 21142 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Pluginpackage 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 = '1.302210'; 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 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 Require000755001750001750 014772042322 17540 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Fork.pm100644001750001750 442314772042322 21142 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::Fork; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; 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 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 Perl.pm100644001750001750 260214772042322 21140 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::Perl; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; 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 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 Workflow000755001750001750 014772042322 20102 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesTask.t100644001750001750 14414772042322 21310 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Workflowuse Test2::Bundle::Extended -target => 'Test2::Workflow::Task'; skip_all "Tests not yet written"; GenTemp.t100644001750001750 200114772042322 21245 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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, File::Spec->catdir($tmp, 'subdir'), File::Spec->catdir($tmp, 'subdir', 'nested'), ); for my $file (qw{foo bar subdir/baz subdir/nested/bat}) { my $cp = File::Spec->catfile($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; Compare.t100644001750001750 15065214772042322 21354 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Subtest.t100644001750001750 2533514772042322 21376 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Exports.t100644001750001750 120114772042322 21353 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Simple.t100644001750001750 34014772042322 21234 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Bundleuse 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__ Delta.t100644001750001750 4642614772042322 21270 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Event.t100644001750001750 117514772042322 21270 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Regex.t100644001750001750 162714772042322 21263 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Undef.t100644001750001750 307214772042322 21246 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Float.t100644001750001750 2236414772042322 21277 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Array.t100644001750001750 1526014772042322 21305 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; no_leaks_any.t100644001750001750 141314772042322 21405 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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; no_log_results.t100644001750001750 40414772042322 21365 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use warnings; use Test::More; sub it { my $tb = Test::Builder->new; $tb->no_log_results; ok(1, "sample"); ok(2, "sample"); is_deeply([$tb->details], [], "no details were logged"); } it(); subtest it => \⁢ done_testing; harness_active.t100644001750001750 266514772042322 21360 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This has to be a require or else the END block below runs before # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 4); # Utility testing functions. sub ok ($;$) { return $TB->ok(@_); } sub main::err_ok ($) { my($expect) = @_; my $got = $err->read; return $TB->is_eq( $got, $expect ); } package main; require Test::More; Test::More->import(tests => 4); Test::More->builder->no_ending(1); { local $ENV{HARNESS_ACTIVE} = 0; local $ENV{HARNESS_IS_VERBOSE} = 0; #line 62 fail( "this fails" ); err_ok( < 1; use Test::Builder::NoOutput; { my $tb = Test::Builder::NoOutput->create; $tb->plan('no_plan'); $tb->ok(1, 'foo'); $tb->_ending; is($tb->read, <new->no_header(1); Test::Builder->new->no_ending(1); local $ENV{HARNESS_ACTIVE} = 0; # Can't use Test.pm, that's a 5.005 thing. package main; my $TB = Test::Builder->create; $TB->plan(tests => 110); # Utility testing functions. sub ok ($;$) { return $TB->ok(@_); } sub is ($$;$) { my($thing, $that, $name) = @_; my $ok = $TB->is_eq($$thing, $that, $name); $$thing = ''; return $ok; } sub like ($$;$) { my($thing, $regex, $name) = @_; $regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s; my $ok = $TB->like($$thing, $regex, $name); $$thing = ''; return $ok; } require Test::More; Test::More->import(tests => 11, import => ['is_deeply']); my $Filename = quotemeta $0; #line 68 ok !is_deeply('foo', 'bar', 'plain strings'); is( $out, "not ok 1 - plain strings\n", 'plain strings' ); is( $err, < 42 }, { this => 43 }, 'hashes with different values'); is( $out, "not ok 3 - hashes with different values\n", 'hashes with different values' ); is( $err, <{this} = '42' # \$expected->{this} = '43' ERR #line 99 ok !is_deeply({ that => 42 }, { this => 42 }, 'hashes with different keys'); is( $out, "not ok 4 - hashes with different keys\n", 'hashes with different keys' ); is( $err, <{this} = Does not exist # \$expected->{this} = '42' ERR #line 110 ok !is_deeply([1..9], [1..10], 'arrays of different length'); is( $out, "not ok 5 - arrays of different length\n", 'arrays of different length' ); is( $err, <[9] = Does not exist # \$expected->[9] = '10' ERR #line 121 ok !is_deeply([undef, undef], [undef], 'arrays of undefs' ); is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' ); is( $err, <[1] = undef # \$expected->[1] = Does not exist ERR #line 131 ok !is_deeply({ foo => undef }, {}, 'hashes of undefs' ); is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' ); is( $err, <{foo} = undef # \$expected->{foo} = Does not exist ERR #line 141 ok !is_deeply(\42, \23, 'scalar refs'); is( $out, "not ok 8 - scalar refs\n", 'scalar refs' ); is( $err, < \$a3 }; # $b2 = { foo => \$b3 }; # is_deeply([$a1], [$b1], 'deep mixed scalar refs'); my $foo = { this => [1..10], that => { up => "down", left => "right" }, }; my $bar = { this => [1..10], that => { up => "down", left => "right", foo => 42 }, }; #line 198 ok !is_deeply( $foo, $bar, 'deep structures' ); ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); is( $out, "not ok 11 - deep structures\n", 'deep structures' ); is( $err, <{that}{foo} = Does not exist # \$expected->{that}{foo} = '42' ERR #line 221 my @tests = ([], [qw(42)], [qw(42 23), qw(42 23)] ); foreach my $test (@tests) { my $num_args = @$test; my $warning; local $SIG{__WARN__} = sub { $warning .= join '', @_; }; ok !is_deeply(@$test); like \$warning, "/^is_deeply\\(\\) takes two or three args, you gave $num_args\.\n/"; } #line 240 # [rt.cpan.org 6837] ok !is_deeply([{Foo => undef}],[{Foo => ""}]), 'undef != ""'; ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); #line 258 # [rt.cpan.org 7031] my $a = []; ok !is_deeply($a, $a.''), "don't compare refs like strings"; ok !is_deeply([$a], [$a.'']), " even deep inside"; #line 265 # [rt.cpan.org 7030] ok !is_deeply( {}, {key => []} ), '[] could match non-existent values'; ok !is_deeply( [], [[]] ); #line 273 $$err = $$out = ''; ok !is_deeply( [\'a', 'b'], [\'a', 'c'] ); is( $out, "not ok 20\n", 'scalar refs in an array' ); is( $err, <[1] = 'b' # \$expected->[1] = 'c' ERR #line 285 my $ref = \23; ok !is_deeply( 23, $ref ); is( $out, "not ok 21\n", 'scalar vs ref' ); is( $err, <[0] = $array # \$expected->[0] = $hash ERR # Overloaded object tests { my $foo = bless [], "Foo"; my $bar = bless {}, "Bar"; { package Bar; "overload"->import(q[""] => sub { "wibble" }); } #line 353 ok !is_deeply( [$foo], [$bar] ); is( $out, "not ok 26\n", 'string overloaded refs respected in diag' ); is( $err, <[0] = $foo # \$expected->[0] = 'wibble' ERR } } # rt.cpan.org 14746 { # line 349 ok !is_deeply( sub {"foo"}, sub {"bar"} ), 'function refs'; is( $out, "not ok 27\n" ); like( $err, < 0}, {x => ''}, "{x => 0} != {x => ''}" ); is( $out, "not ok 39 - {x => 0} != {x => ''}\n" ); ok !is_deeply( {x => 0}, {x => undef}, "{x => 0} != {x => undef}" ); is( $out, "not ok 40 - {x => 0} != {x => undef}\n" ); ok !is_deeply( {x => ''}, {x => undef}, "{x => ''} != {x => undef}" ); is( $out, "not ok 41 - {x => ''} != {x => undef}\n" ); } # this will also happily fail before 5.10, even though there's no VSTRING ref type { my $version1 = v1.2.3; my $version2 = v1.2.4; ok !is_deeply( [\\$version1], [\\$version2], "version objects"); is( $out, "not ok 42 - version objects\n" ); } { my $version1 = v1.2.3; my $version2 = '' . v1.2.3; ok is_deeply( [\$version1], [\$version2], "version objects"); is( $out, "ok 43 - version objects\n" ); } { my $version1 = v1.2.3; my $version2 = v1.2.3; ok !is_deeply( [$version1], [\$version2], "version objects"); is( $out, "not ok 44 - version objects\n" ); } { my $string = "abc"; my $string2 = "b"; ok is_deeply( [\substr($string, 1, 1)], [\$string2], "lvalue ref"); is( $out, "ok 45 - lvalue ref\n" ); } { my $string = "b"; my $string2 = "b"; ok !is_deeply( [\substr($string, 1, 1)], ["b"], "lvalue ref"); is( $out, "not ok 46 - lvalue ref\n" ); } events.t100644001750001750 57014772042322 21330 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtestuse strict; use warnings; use Test::More; use Test2::API qw/intercept/; my $events = intercept { subtest foo => sub { ok(1, "pass"); }; }; my $st = $events->[-1]; isa_ok($st, 'Test2::Event::Subtest'); ok(my $id = $st->subtest_id, "got an id"); for my $se (@{$st->subevents}) { is($se->trace->hid, $id, "set subtest_id on child event"); } done_testing; Regression000755001750001750 014772042322 20144 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy637.t100644001750001750 235414772042322 21014 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Regressionuse strict; use warnings; # HARNESS-NO-STREAM use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { print "1..0 # Skip threads are not supported.\n"; exit 0; } } BEGIN { unless ( $ENV{AUTHOR_TESTING} ) { print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; exit 0; } } use Test2::IPC; use threads; use Test::More; plan 'skip_all' => "This test cannot be run with the current formatter" unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); ok 1 for (1 .. 2); # used to reset the counter after thread finishes my $ct_num = Test::More->builder->current_test; my $subtest_out = async { my $out = ''; #simulate a subtest to not confuse the parent TAP emission my $tb = Test::More->builder; $tb->reset; for (qw/output failure_output todo_output/) { close $tb->$_; open($tb->$_, '>', \$out); } ok 1 for (1 .. 3); done_testing; close $tb->$_ for (qw/output failure_output todo_output/); $out; } ->join; $subtest_out =~ s/^/ /gm; print $subtest_out; # reset as if the thread never "said" anything Test::More->builder->current_test($ct_num); ok 1 for (1 .. 4); done_testing; ok_obj.t100644001750001750 71614772042322 21166 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # Testing to make sure Test::Builder doesn't accidentally store objects # passed in as test arguments. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More tests => 4; package Foo; my $destroyed = 0; sub new { bless {}, shift } sub DESTROY { $destroyed++; } package main; for (1..3) { ok(my $foo = Foo->new, 'created Foo object'); } is $destroyed, 3, "DESTROY called 3 times"; create.t100644001750001750 146214772042322 21205 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More tests => 7; use Test::Builder; use Test::Builder::NoOutput; my $more_tb = Test::More->builder; isa_ok $more_tb, 'Test::Builder'; is $more_tb, Test::More->builder, 'create does not interfere with ->builder'; is $more_tb, Test::Builder->new, ' does not interfere with ->new'; { my $new_tb = Test::Builder::NoOutput->create; isa_ok $new_tb, 'Test::Builder'; isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object'; $new_tb->plan(tests => 1); $new_tb->ok(1, "a test"); is $new_tb->read, <<'OUT'; 1..1 ok 1 - a test OUT } pass("Changing output() of new TB doesn't interfere with singleton"); output.t100644001750001750 371314772042322 21303 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!perl -w use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; use Test::Builder; # The real Test::Builder my $Test = Test::Builder->new; $Test->plan( tests => 6 ); # The one we're going to test. my $tb = Test::Builder->create(); my $tmpfile = 'foo.tmp'; END { 1 while unlink($tmpfile) } # Test output to a file { my $out = $tb->output($tmpfile); $Test->ok( defined $out ); print $out "hi!\n"; close *$out; undef $out; open(IN, $tmpfile) or die $!; chomp(my $line = ); close IN; $Test->is_eq($line, 'hi!'); } # Test output to a filehandle { open(FOO, ">>$tmpfile") or die $!; my $out = $tb->output(\*FOO); my $old = select *$out; print "Hello!\n"; close *$out; undef $out; select $old; open(IN, $tmpfile) or die $!; my @lines = ; close IN; $Test->like($lines[1], qr/Hello!/); } # Test output to a scalar ref { my $scalar = ''; my $out = $tb->output(\$scalar); print $out "Hey hey hey!\n"; $Test->is_eq($scalar, "Hey hey hey!\n"); } # Test we can output to the same scalar ref { my $scalar = ''; my $out = $tb->output(\$scalar); my $err = $tb->failure_output(\$scalar); print $out "To output "; print $err "and beyond!"; $Test->is_eq($scalar, "To output and beyond!", "One scalar, two filehandles"); } # Ensure stray newline in name escaping works. { my $fakeout = ''; my $out = $tb->output(\$fakeout); $tb->exported_to(__PACKAGE__); $tb->no_ending(1); $tb->plan(tests => 5); $tb->ok(1, "ok"); $tb->ok(1, "ok\n"); $tb->ok(1, "ok, like\nok"); $tb->skip("wibble\nmoof"); $tb->todo_skip("todo\nskip\n"); $Test->is_eq( $fakeout, <create( sub { ok(1, "Pass thread"); } ); $thread->join; } done_testing; Test2-Mock.t100644001750001750 141114772042322 21212 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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; Workflow000755001750001750 014772042322 17736 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Task.pm100644001750001750 746214772042322 21347 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Workflowpackage Test2::Workflow::Task; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Subtest.pm100644001750001750 646714772042322 21351 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Subtest; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid start_stamp stop_stamp}; sub init { my $self = shift; $self->SUPER::init(); $self->{+SUBEVENTS} ||= []; if ($self->{+EFFECTIVE_PASS}) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; } } { no warnings 'redefine'; sub set_subevents { my $self = shift; my @subevents = @_; if ($self->{+EFFECTIVE_PASS}) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; } $self->{+SUBEVENTS} = \@subevents; } sub set_effective_pass { my $self = shift; my ($pass) = @_; if ($pass) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; } elsif ($self->{+EFFECTIVE_PASS} && !$pass) { for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; } } $self->{+EFFECTIVE_PASS} = $pass; } } sub summary { my $self = shift; my $name = $self->{+NAME} || "Nameless Subtest"; my $todo = $self->{+TODO}; if ($todo) { $name .= " (TODO: $todo)"; } elsif (defined $todo) { $name .= " (TODO)"; } return $name; } sub facet_data { my $self = shift; my $out = $self->SUPER::facet_data(); my $start = $self->start_stamp; my $stop = $self->stop_stamp; $out->{parent} = { hid => $self->subtest_id, children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}], buffered => $self->{+BUFFERED}, $start ? (start_stamp => $start) : (), $stop ? (stop_stamp => $stop) : (), }; return $out; } sub add_amnesty { my $self = shift; for my $am (@_) { $am = {%$am} if ref($am) ne 'ARRAY'; $am = Test2::EventFacet::Amnesty->new($am); push @{$self->{+AMNESTY}} => $am; for my $e (@{$self->{+SUBEVENTS}}) { $e->add_amnesty($am->clone(inherited => 1)); } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Subtest - Event for subtest types =head1 DESCRIPTION This class represents a subtest. This class is a subclass of L. =head1 ACCESSORS This class inherits from L. =over 4 =item $arrayref = $e->subevents Returns the arrayref containing all the events from the subtest =item $bool = $e->buffered True if the subtest is buffered, that is all subevents render at once. If this is false it means all subevents render as they are produced. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Waiting.pm100644001750001750 232314772042322 21305 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Waiting; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; sub global { 1 }; sub summary { "IPC is waiting for children to finish..." } sub facet_data { my $self = shift; my $out = $self->common_facet_data; push @{$out->{info}} => { tag => 'INFO', debug => 0, details => $self->summary, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Waiting - Tell all procs/threads it is time to be done =head1 DESCRIPTION This event has no data of its own. This event is sent out by the IPC system when the main process/thread is ready to end. =head1 SOURCE The source code repository for Test2 can be found at 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 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 Generic.pm100644001750001750 1342214772042322 21301 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Generic; use strict; use warnings; use Carp qw/croak/; use Scalar::Util qw/reftype/; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; my @FIELDS = qw{ causes_fail increments_count diagnostics no_display callback terminate global sets_plan summary facet_data }; my %DEFAULTS = ( causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, ); sub init { my $self = shift; for my $field (@FIELDS) { my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field}; next unless defined $val; my $set = "set_$field"; $self->$set($val); } } for my $field (@FIELDS) { no strict 'refs'; *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } unless exists &{$field}; *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } unless exists &{"set_$field"}; } sub can { my $self = shift; my ($name) = @_; return $self->SUPER::can($name) unless $name eq 'callback'; return $self->{callback} || \&Test2::Event::callback; } sub facet_data { my $self = shift; return $self->{facet_data} || $self->SUPER::facet_data(); } sub summary { my $self = shift; return $self->{summary} if defined $self->{summary}; $self->SUPER::summary(); } sub sets_plan { my $self = shift; return unless $self->{sets_plan}; return @{$self->{sets_plan}}; } sub callback { my $self = shift; my $cb = $self->{callback} || return; $self->$cb(@_); } sub set_global { my $self = shift; my ($bool) = @_; if(!defined $bool) { delete $self->{global}; return undef; } $self->{global} = $bool; } sub set_callback { my $self = shift; my ($cb) = @_; if(!defined $cb) { delete $self->{callback}; return undef; } croak "callback must be a code reference" unless ref($cb) && reftype($cb) eq 'CODE'; $self->{callback} = $cb; } sub set_terminate { my $self = shift; my ($exit) = @_; if(!defined $exit) { delete $self->{terminate}; return undef; } croak "terminate must be a positive integer" unless $exit =~ m/^\d+$/; $self->{terminate} = $exit; } sub set_sets_plan { my $self = shift; my ($plan) = @_; if(!defined $plan) { delete $self->{sets_plan}; return undef; } croak "'sets_plan' must be an array reference" unless ref($plan) && reftype($plan) eq 'ARRAY'; $self->{sets_plan} = $plan; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Generic - Generic event type. =head1 DESCRIPTION This is a generic event that lets you customize all fields in the event API. This is useful if you have need for a custom event that does not make sense as a published reusable event subclass. =head1 SYNOPSIS use Test2::API qw/context/; sub send_custom_fail { my $ctx = shift; $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling'); $ctx->release; } send_custom_fail(); =head1 METHODS =over 4 =item $e->facet_data($data) =item $data = $e->facet_data Get or set the facet data (see L). If no facet_data is set then C<< Test2::Event->facet_data >> will be called to produce facets from the other data. =item $e->callback($hub) Call the custom callback if one is set, otherwise this does nothing. =item $e->set_callback(sub { ... }) Set the custom callback. The custom callback must be a coderef. The first argument to your callback will be the event itself, the second will be the L that is using the callback. =item $bool = $e->causes_fail =item $e->set_causes_fail($bool) Get/Set the C attribute. This defaults to C<0>. =item $bool = $e->diagnostics =item $e->set_diagnostics($bool) Get/Set the C attribute. This defaults to C<0>. =item $bool_or_undef = $e->global =item @bool_or_empty = $e->global =item $e->set_global($bool_or_undef) Get/Set the C attribute. This defaults to an empty list which is undef in scalar context. =item $bool = $e->increments_count =item $e->set_increments_count($bool) Get/Set the C attribute. This defaults to C<0>. =item $bool = $e->no_display =item $e->set_no_display($bool) Get/Set the C attribute. This defaults to C<0>. =item @plan = $e->sets_plan Get the plan if this event sets one. The plan is a list of up to 3 items: C<($count, $directive, $reason)>. C<$count> must be defined, the others may be undef, or may not exist at all. =item $e->set_sets_plan(\@plan) Set the plan. You must pass in an arrayref with up to 3 elements. =item $summary = $e->summary =item $e->set_summary($summary_or_undef) Get/Set the summary. This will default to the event package C<'Test2::Event::Generic'>. You can set it to any value. Setting this to C will reset it to the default. =item $int_or_undef = $e->terminate =item @int_or_empty = $e->terminate =item $e->set_terminate($int_or_undef) This will get/set the C attribute. This defaults to undef in scalar context, or an empty list in list context. Setting this to undef will clear it completely. This must be set to a positive integer (0 or larger). =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 Importer.pm100644001750001750 5403314772042322 21365 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Importer; use strict; no strict 'refs'; use warnings; no warnings 'once'; our $VERSION = '1.302210'; 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 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 HashBase.pm100644001750001750 3164214772042322 21243 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::HashBase; use strict; use warnings; our $VERSION = '1.302210'; ################################################################# # # # This is a generated file! Do not modify this file directly! # # Use hashbase_inc.pl script to regenerate this file. # # The script is part of the Object::HashBase distribution. # # Note: You can modify the version number above this comment # # if needed, that is fine. # # # ################################################################# { no warnings 'once'; $Test2::Util::HashBase::HB_VERSION = '0.009'; *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION; *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; } require Carp; { no warnings 'once'; $Carp::Internal{+__PACKAGE__} = 1; } BEGIN { # these are not strictly equivalent, but for out use we don't care # about order *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { no strict 'refs'; my @packages = ($_[0]); my %seen; for my $package (@packages) { push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; } return \@packages; } } my %SPEC = ( '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, ); sub import { my $class = shift; my $into = caller; # Make sure we list the OLDEST version used to create this class. my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION; $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver; my $isa = _isa($into); my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= []; my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {}; my %subs = ( ($into->can('new') ? () : (new => \&_new)), (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), ( map { my $p = substr($_, 0, 1); my $x = $_; my $spec = $SPEC{$p} || {reader => 1, writer => 1}; substr($x, 0, 1) = '' if $spec->{strip}; push @$attr_list => $x; my ($sub, $attr) = (uc $x, $x); $attr_subs->{$sub} = sub() { $attr }; my %out = ($sub => $attr_subs->{$sub}); $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; %out; } @_ ), ); no strict 'refs'; *{"$into\::$_"} = $subs{$_} for keys %subs; } sub attr_list { my $class = shift; my $isa = _isa($class); my %seen; my @list = grep { !$seen{$_}++ } map { my @out; if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) { Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()"); } else { my $list = $Test2::Util::HashBase::ATTR_LIST{$_}; @out = $list ? @$list : () } @out; } reverse @$isa; return @list; } sub _new { my $class = shift; my $self; if (@_ == 1) { my $arg = shift; my $type = ref($arg); if ($type eq 'HASH') { $self = bless({%$arg}, $class) } else { Carp::croak("Not sure what to do with '$type' in $class constructor") unless $type eq 'ARRAY'; my %proto; my @attributes = attr_list($class); while (@$arg) { my $val = shift @$arg; my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); $proto{$key} = $val; } $self = bless(\%proto, $class); } } else { $self = bless({@_}, $class); } $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init') unless exists $Test2::Util::HashBase::CAN_CACHE{$class}; $self->init if $Test2::Util::HashBase::CAN_CACHE{$class}; $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::HashBase - Build hash based classes. =head1 SYNOPSIS A class: package My::Class; use strict; use warnings; # Generate 3 accessors use Test2::Util::HashBase qw/foo -bar ^baz ban +boo/; # Chance to initialize defaults sub init { my $self = shift; # No other args $self->{+FOO} ||= "foo"; $self->{+BAR} ||= "bar"; $self->{+BAZ} ||= "baz"; $self->{+BAT} ||= "bat"; $self->{+BAN} ||= "ban"; $self->{+BOO} ||= "boo"; } sub print { print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; } Subclass it package My::Subclass; use strict; use warnings; # Note, you should subclass before loading HashBase. use base 'My::Class'; use Test2::Util::HashBase qw/bub/; sub init { my $self = shift; # We get the constants from the base class for free. $self->{+FOO} ||= 'SubFoo'; $self->{+BUB} ||= 'bub'; $self->SUPER::init(); } use it: package main; use strict; use warnings; use My::Class; # These are all functionally identical my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); my $three = My::Class->new(['MyFoo', 'MyBar']); # Readers! my $foo = $one->foo; # 'MyFoo' my $bar = $one->bar; # 'MyBar' my $baz = $one->baz; # Defaulted to: 'baz' my $bat = $one->bat; # Defaulted to: 'bat' # '>ban' means setter only, no reader # '+boo' means no setter or reader, just the BOO constant # Setters! $one->set_foo('A Foo'); #'-bar' means read-only, so the setter will throw an exception (but is defined). $one->set_bar('A bar'); # '^baz' means deprecated setter, this will warn about the setter being # deprecated. $one->set_baz('A Baz'); # '{+FOO} = 'xxx'; =head1 DESCRIPTION This package is used to generate classes based on hashrefs. Using this class will give you a C method, as well as generating accessors you request. Generated accessors will be getters, C setters will also be generated for you. You also get constants for each accessor (all caps) which return the key into the hash for that accessor. Single inheritance is also supported. =head1 THIS IS A BUNDLED COPY OF HASHBASE This is a bundled copy of L. This file was generated using the C script. =head1 METHODS =head2 PROVIDED BY HASH BASE =over 4 =item $it = $class->new(%PAIRS) =item $it = $class->new(\%PAIRS) =item $it = $class->new(\@ORDERED_VALUES) Create a new instance. HashBase will not export C if there is already a C method in your packages inheritance chain. B you just have to declare it before loading L. package My::Package; # predeclare new() so that HashBase does not give us one. sub new; use Test2::Util::HashBase qw/foo bar baz/; # Now we define our own new method. sub new { ... } This makes it so that HashBase sees that you have your own C method. Alternatively you can define the method before loading HashBase instead of just declaring it, but that scatters your use statements. The most common way to create an object is to pass in key/value pairs where each key is an attribute and each value is what you want assigned to that attribute. No checking is done to verify the attributes or values are valid, you may do that in C if desired. If you would like, you can pass in a hashref instead of pairs. When you do so the hashref will be copied, and the copy will be returned blessed as an object. There is no way to ask HashBase to bless a specific hashref. In some cases an object may only have 1 or 2 attributes, in which case a hashref may be too verbose for your liking. In these cases you can pass in an arrayref with only values. The values will be assigned to attributes in the order the attributes were listed. When there is inheritance involved the attributes from parent classes will come before subclasses. =back =head2 HOOKS =over 4 =item $self->init() This gives you the chance to set some default values to your fields. The only argument is C<$self> with its indexes already set from the constructor. B Test2::Util::HashBase checks for an init using C<< $class->can('init') >> during construction. It DOES NOT call C on the created object. Also note that the result of the check is cached, it is only ever checked once, the first time an instance of your class is created. This means that adding an C method AFTER the first construction will result in it being ignored. =back =head1 ACCESSORS =head2 READ/WRITE To generate accessors you list them when using the module: use Test2::Util::HashBase qw/foo/; This will generate the following subs in your namespace: =over 4 =item foo() Getter, used to get the value of the C field. =item set_foo() Setter, used to set the value of the C field. =item FOO() Constant, returns the field C's key into the class hashref. Subclasses will also get this function as a constant, not simply a method, that means it is copied into the subclass namespace. The main reason for using these constants is to help avoid spelling mistakes and similar typos. It will not help you if you forget to prefix the '+' though. =back =head2 READ ONLY use Test2::Util::HashBase qw/-foo/; =over 4 =item set_foo() Throws an exception telling you the attribute is read-only. This is exported to override any active setters for the attribute in a parent class. =back =head2 DEPRECATED SETTER use Test2::Util::HashBase qw/^foo/; =over 4 =item set_foo() This will set the value, but it will also warn you that the method is deprecated. =back =head2 NO SETTER use Test2::Util::HashBase qw/ method is defined at all. =head2 NO READER use Test2::Util::HashBase qw/>foo/; Only gives you a write (C), no C method is defined at all. =head2 CONSTANT ONLY use Test2::Util::HashBase qw/+foo/; This does not create any methods for you, it just adds the C constant. =head1 SUBCLASSING You can subclass an existing HashBase class. use base 'Another::HashBase::Class'; use Test2::Util::HashBase qw/foo bar baz/; The base class is added to C<@ISA> for you, and all constants from base classes are added to subclasses automatically. =head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS Test2::Util::HashBase provides a function for retrieving a list of attributes for an Test2::Util::HashBase class. =over 4 =item @list = Test2::Util::HashBase::attr_list($class) =item @list = $class->Test2::Util::HashBase::attr_list() Either form above will work. This will return a list of attributes defined on the object. This list is returned in the attribute definition order, parent class attributes are listed before subclass attributes. Duplicate attributes will be removed before the list is returned. B This list is used in the C<< $class->new(\@ARRAY) >> constructor to determine the attribute to which each value will be paired. =back =head1 SOURCE The source code repository for HashBase 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 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 GenTemp.pm100644001750001750 461614772042322 21270 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::GenTemp; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Subtest.pm100644001750001750 724414772042322 21362 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Subtest; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Compare.pm100644001750001750 14176214772042322 21363 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Compare; use strict; use warnings; our $VERSION = '1.302210'; 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/\A[0-9]+\z/}, "'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/\A[0-9]+\z/); # 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 strings '2.0' and '2' will not match, but numeric 2.0 and 2 will, since they are both stringified to '2'. =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/\A[0-9]+\z/}, "'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 to 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 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 Exports.pm100644001750001750 760514772042322 21376 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Exports; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Formatter000755001750001750 014772042322 20067 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2TAP.pm100644001750001750 3323614772042322 21240 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Formatterpackage Test2::Formatter::TAP; use strict; use warnings; our $VERSION = '1.302210'; use Test2::Util qw/clone_io/; use Test2::Util::HashBase qw{ no_numbers handles _encoding _last_fh -made_assertion }; sub OUT_STD() { 0 } sub OUT_ERR() { 1 } BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } my $supports_tables; sub supports_tables { if (!defined $supports_tables) { local $SIG{__DIE__} = 'DEFAULT'; local $@; $supports_tables = ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'}) || eval { require Term::Table; require Term::Table::Util; 1 } || 0; } return $supports_tables; } sub _autoflush { my($fh) = pop; my $old_fh = select $fh; $| = 1; select $old_fh; } _autoflush(\*STDOUT); _autoflush(\*STDERR); sub hide_buffered { 1 } sub init { my $self = shift; $self->{+HANDLES} ||= $self->_open_handles; if(my $enc = delete $self->{encoding}) { $self->encoding($enc); } } sub _open_handles { my $self = shift; require Test2::API; my $out = clone_io(Test2::API::test2_stdout()); my $err = clone_io(Test2::API::test2_stderr()); _autoflush($out); _autoflush($err); return [$out, $err]; } sub encoding { my $self = shift; if ("$]" >= 5.007003 and @_) { my ($enc) = @_; my $handles = $self->{+HANDLES}; # https://rt.perl.org/Public/Bug/Display.html?id=31923 # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in # order to avoid the thread segfault. if ($enc =~ m/^utf-?8$/i) { binmode($_, ":utf8") for @$handles; } else { binmode($_, ":encoding($enc)") for @$handles; } $self->{+_ENCODING} = $enc; } return $self->{+_ENCODING}; } if ($^C) { no warnings 'redefine'; *write = sub {}; } sub write { my ($self, $e, $num, $f) = @_; # The most common case, a pass event with no amnesty and a normal name. return if $self->print_optimal_pass($e, $num); $f ||= $e->facet_data; $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; my @tap = $self->event_tap($f, $num) or return; $self->{+MADE_ASSERTION} = 1 if $f->{assert}; my $nesting = $f->{trace}->{nested} || 0; my $handles = $self->{+HANDLES}; my $indent = ' ' x $nesting; # Local is expensive! Only do it if we really need to. local($\, $,) = (undef, '') if $\ || $,; for my $set (@tap) { no warnings 'uninitialized'; my ($hid, $msg) = @$set; next unless $msg; my $io = $handles->[$hid] or next; print $io "\n" if $ENV{HARNESS_ACTIVE} && $hid == OUT_ERR && $self->{+_LAST_FH} != $io && $msg =~ m/^#\s*Failed( \(TODO\))? test /; $msg =~ s/^/$indent/mg if $nesting; print $io $msg; $self->{+_LAST_FH} = $io; } } sub print_optimal_pass { my ($self, $e, $num) = @_; my $type = ref($e); # Only optimal if this is a Pass or a passing Ok return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass}); # Amnesty requires further processing (todo is a form of amnesty) return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo}); # A name with a newline or hash symbol needs extra processing return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#')); my $ok = 'ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n"; if (my $nesting = $e->{trace}->{nested}) { my $indent = ' ' x $nesting; $ok = "$indent$ok"; } my $io = $self->{+HANDLES}->[OUT_STD]; local($\, $,) = (undef, '') if $\ || $,; print $io $ok; $self->{+_LAST_FH} = $io; return 1; } sub event_tap { my ($self, $f, $num) = @_; my @tap; # If this IS the first event the plan should come first # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION}; # The assertion is most important, if present. if ($f->{assert}) { push @tap => $self->assert_tap($f, $num); push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass}; } # Almost as important as an assertion push @tap => $self->error_tap($f) if $f->{errors}; # Now lets see the diagnostics messages push @tap => $self->info_tap($f) if $f->{info}; # If this IS NOT the first event the plan should come last # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan}; # Bail out push @tap => $self->halt_tap($f) if $f->{control}->{halt}; return @tap if @tap; return @tap if $f->{control}->{halt}; return @tap if grep { $f->{$_} } qw/assert plan info errors/; # Use the summary as a fallback if nothing else is usable. return $self->summary_tap($f, $num); } sub error_tap { my $self = shift; my ($f) = @_; my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR; return map { my $details = $_->{details}; my $msg; if (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{errors}}; } sub plan_tap { my $self = shift; my ($f) = @_; my $plan = $f->{plan} or return; return if $plan->{none}; if ($plan->{skip}) { my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"]; chomp($reason); return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"]; } return [OUT_STD, "1.." . $plan->{count} . "\n"]; } sub no_subtest_space { 0 } sub assert_tap { my $self = shift; my ($f, $num) = @_; my $assert = $f->{assert} or return; my $pass = $assert->{pass}; my $name = $assert->{details}; my $ok = $pass ? 'ok' : 'not ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; # The regex form is ~250ms, the index form is ~50ms my @extra; defined($name) && ( (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))), ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g))) ); my $extra_space = @extra ? ' ' x (length($ok) + 2) : ''; my $extra_indent = ''; my ($directives, $reason, $is_skip); if ($f->{amnesty}) { my %directives; for my $am (@{$f->{amnesty}}) { next if $am->{inherited}; my $tag = $am->{tag} or next; $is_skip = 1 if $tag eq 'skip'; $directives{$tag} ||= $am->{details}; } my %seen; # Sort so that TODO comes before skip even on systems where lc sorts # before uc, as other code depends on that ordering. my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives; $directives = ' # ' . join ' & ' => @order; for my $tag ('skip', @order) { next unless defined($directives{$tag}) && length($directives{$tag}); $reason = $directives{$tag}; last; } } $ok .= " - $name" if defined $name && !($is_skip && !$name); my @subtap; if ($f->{parent} && $f->{parent}->{buffered}) { $ok .= ' {'; # In a verbose harness we indent the extra since they will appear # inside the subtest braces. This helps readability. In a non-verbose # harness we do not do this because it is less readable. if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) { $extra_indent = " "; $extra_space = ' '; } # Render the sub-events, we use our own counter for these. my $count = 0; @subtap = map { my $f2 = $_; # Bump the count for any event that should bump it. $count++ if $f2->{assert}; # This indents all output lines generated for the sub-events. # index 0 is the filehandle, index 1 is the message we want to indent. map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count); } @{$f->{parent}->{children}}; push @subtap => [OUT_STD, "}\n"]; } if ($directives) { $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip'; $ok .= $directives; $ok .= " $reason" if defined($reason); } $extra_space = ' ' if $self->no_subtest_space; my @out = ([OUT_STD, "$ok\n"]); push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra; push @out => @subtap; return @out; } sub debug_tap { my ($self, $f, $num) = @_; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $f->{assert}->{details}; my $trace = $f->{trace}; my $debug = "[No trace info available]"; if ($trace->{details}) { $debug = $trace->{details}; } elsif ($trace->{frame}) { my ($pkg, $file, $line) = @{$trace->{frame}}; $debug = "at $file line $line." if $file && $line; } my $amnesty = $f->{amnesty} && @{$f->{amnesty}} ? ' (with amnesty)' : ''; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[# Failed test${amnesty} '$name'\n# $debug\n] : qq[# Failed test${amnesty} $debug\n]; my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR; return [$IO, $msg]; } sub halt_tap { my ($self, $f) = @_; return if $f->{trace}->{nested} && !$f->{trace}->{buffered}; my $details = $f->{control}->{details}; return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details); return [OUT_STD, "Bail out! $details\n"]; } sub info_tap { my ($self, $f) = @_; return map { my $details = $_->{details}; my $table = $_->{table}; my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD; my $msg; if ($table && $self->supports_tables) { my $size = $self->calc_table_size($f); $msg = join "\n" => map { "# $_" } Term::Table->new( header => $table->{header}, rows => $table->{rows}, collapse => $table->{collapse}, no_collapse => $table->{no_collapse}, sanitize => 1, mark_tail => 1, max_width => $size, )->render(); $msg .= "\n(If this table is too small, you can use the TABLE_TERM_SIZE=### env var to set a larger size, detected size is '$size')\n" if $size <= 80 && !$ENV{TABLE_TERM_SIZE}; } elsif (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{info}}; } sub summary_tap { my ($self, $f, $num) = @_; return if $f->{about}->{no_display}; my $summary = $f->{about}->{details} or return; chomp($summary); $summary =~ s/^/# /smg; return [OUT_STD, "$summary\n"]; } sub calc_table_size { my $self = shift; my ($f) = @_; my $term = Term::Table::Util::term_size(); my $nesting = 2 + (($f->{trace}->{nested} || 0) * 4); # 4 spaces per level, also '# ' prefix my $total = $term - $nesting; # Sane minimum width, any smaller and we are asking for pain return 50 if $total < 50; return $total; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter::TAP - Standard TAP formatter =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test2::Formatter::TAP; my $tap = Test2::Formatter::TAP->new(); # Switch to utf8 $tap->encoding('utf8'); $tap->write($event, $number); # Output an event =head1 METHODS =over 4 =item $bool = $tap->no_numbers =item $tap->set_no_numbers($bool) Use to turn numbers on and off. =item $arrayref = $tap->handles =item $tap->set_handles(\@handles); Can be used to get/set the filehandles. Indexes are identified by the C and C constants. =item $encoding = $tap->encoding =item $tap->encoding($encoding) Get or set the encoding. By default no encoding is set, the original settings of STDOUT and STDERR are used. This directly modifies the stored filehandles, it does not create new ones. =item $tap->write($e, $num) Write an event to the console. =back =head1 SOURCE The source code repository for Test2 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 =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 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 Simple.pm100644001750001750 373314772042322 21272 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Bundlepackage Test2::Bundle::Simple; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Regex.pm100644001750001750 301714772042322 21263 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Regex; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Undef.pm100644001750001750 241514772042322 21253 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Undef; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Array.pm100644001750001750 2007314772042322 21310 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Array; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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) { last if $overflow; # avoid doing 'for each' checks beyond array bounds $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 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 Float.pm100644001750001750 774714772042322 21274 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Float; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Delta.pm100644001750001750 3335014772042322 21265 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Delta; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Event.pm100644001750001750 250114772042322 21267 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Event; use strict; use warnings; use Scalar::Util qw/blessed/; use Test2::Compare::EventMeta(); use base 'Test2::Compare::Object'; our $VERSION = '1.302210'; 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 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 Tester000755001750001750 014772042322 17310 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/TestCapture.pm100644001750001750 1045514772042322 21436 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Testeruse strict; package Test::Tester::Capture; our $VERSION = '1.302210'; use Test::Builder; our @ISA = qw( Test::Builder ); # Make Test::Tester::Capture thread-safe for ithreads. BEGIN { use Config; *share = sub { 0 }; *lock = sub { 0 }; } my $Curr_Test = 0; share($Curr_Test); my @Test_Results = (); share(@Test_Results); my $Prem_Diag = {diag => ""}; share($Curr_Test); sub new { # Test::Tester::Capgture::new used to just return __PACKAGE__ # because Test::Builder::new enforced its singleton nature by # return __PACKAGE__. That has since changed, Test::Builder::new now # returns a blessed has and around version 0.78, Test::Builder::todo # started wanting to modify $self. To cope with this, we now return # a blessed hash. This is a short-term hack, the correct thing to do # is to detect which style of Test::Builder we're dealing with and # act appropriately. my $class = shift; return bless {}, $class; } sub ok { my($self, $test, $name) = @_; my $ctx = $self->ctx; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; lock $Curr_Test; $Curr_Test++; my($pack, $file, $line) = $self->caller; my $todo = $self->todo(); my $result = {}; share($result); unless( $test ) { @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $result->{name} = $name; } else { $result->{name} = ''; } if( $todo ) { my $what_todo = $todo; $result->{reason} = $what_todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $Test_Results[$Curr_Test-1] = $result; unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $result->{fail_diag} = (" $msg test ($file at line $line)\n"); } $result->{diag} = ""; $result->{_level} = $Test::Builder::Level; $result->{_depth} = Test::Tester::find_run_tests(); $ctx->release; return $test ? 1 : 0; } sub skip { my($self, $why) = @_; $why ||= ''; my $ctx = $self->ctx; lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, diag => "", _level => $Test::Builder::Level, _depth => Test::Tester::find_run_tests(), ); $Test_Results[$Curr_Test-1] = \%result; $ctx->release; return 1; } sub todo_skip { my($self, $why) = @_; $why ||= ''; my $ctx = $self->ctx; lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, diag => "", _level => $Test::Builder::Level, _depth => Test::Tester::find_run_tests(), ); $Test_Results[$Curr_Test-1] = \%result; $ctx->release; return 1; } sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; my $ctx = $self->ctx; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; $result->{diag} .= join("", @msgs); $ctx->release; return 0; } sub details { return @Test_Results; } # Stub. Feel free to send me a patch to implement this. sub note { } sub explain { return Test::Builder::explain(@_); } sub premature { return $Prem_Diag->{diag}; } sub current_test { if (@_ > 1) { die "Don't try to change the test number!"; } else { return $Curr_Test; } } sub reset { $Curr_Test = 0; @Test_Results = (); $Prem_Diag = {diag => ""}; } 1; __END__ =head1 NAME Test::Tester::Capture - Help testing test modules built with Test::Builder =head1 DESCRIPTION This is a subclass of Test::Builder that overrides many of the methods so that they don't output anything. It also keeps track of its own set of test results so that you can use Test::Builder based modules to perform tests on other Test::Builder based modules. =head1 AUTHOR Most of the code here was lifted straight from Test::Builder and then had chunks removed by Fergal Daly . =head1 LICENSE Under the same license as Perl itself See L =cut Builder000755001750001750 014772042322 17430 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/TestTester.pm100644001750001750 4316314772042322 21423 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Builderpackage Test::Builder::Tester; use strict; our $VERSION = '1.302210'; use Test::Builder; use Symbol; use Carp; =head1 NAME Test::Builder::Tester - test testsuites that have been built with Test::Builder =head1 SYNOPSIS use Test::Builder::Tester tests => 1; use Test::More; test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); =head1 DESCRIPTION A module that helps you test testing modules that are built with L. The testing system is designed to be used by performing a three step process for each test you wish to test. This process starts with using C and C in advance to declare what the testsuite you are testing will output with L to stdout and stderr. You then can run the test(s) from your test suite that call L. At this point the output of L is safely captured by L rather than being interpreted as real test output. The final stage is to call C that will simply compare what you predeclared to what L actually outputted, and report the results back with a "ok" or "not ok" (with debugging) to the normal output. =cut #### # set up testing #### my $t = Test::Builder->new; ### # make us an exporter ### use Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); sub import { my $class = shift; my(@plan) = @_; my $caller = caller; $t->exported_to($caller); $t->plan(@plan); my @imports = (); foreach my $idx ( 0 .. $#plan ) { if( $plan[$idx] eq 'import' ) { @imports = @{ $plan[ $idx + 1 ] }; last; } } __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); } ### # set up file handles ### # create some private file handles my $output_handle = gensym; my $error_handle = gensym; # and tie them to this package my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; #### # exported functions #### # for remembering that we're testing and where we're testing at my $testing = 0; my $testing_num; my $original_is_passing; # remembering where the file handles were originally connected my $original_output_handle; my $original_failure_handle; my $original_todo_handle; my $original_formatter; my $original_harness_env; # function that starts testing and redirects the filehandles for now sub _start_testing { # Hack for things that conditioned on Test-Stream being loaded $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'}; # even if we're running under Test::Harness pretend we're not # for now. This needed so Test::Builder doesn't add extra spaces $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top); $original_formatter = $hub->format; unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) { my $fmt = Test::Builder::Formatter->new; $hub->format($fmt); } # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); $original_todo_handle = $t->todo_output(); # switch out to our own handles $t->output($output_handle); $t->failure_output($error_handle); $t->todo_output($output_handle); # clear the expected list $out->reset(); $err->reset(); # remember that we're testing $testing = 1; $testing_num = $t->current_test; $t->current_test(0); $original_is_passing = $t->is_passing; $t->is_passing(1); # look, we shouldn't do the ending stuff $t->no_ending(1); } =head2 Functions These are the six methods that are exported as default. =over 4 =item test_out =item test_err Procedures for predeclaring the output that your test suite is expected to produce until C is called. These procedures automatically assume that each line terminates with "\n". So test_out("ok 1","ok 2"); is the same as test_out("ok 1\nok 2"); which is even the same as test_out("ok 1"); test_out("ok 2"); Once C or C (or C or C) have been called, all further output from L will be captured by L. This means that you will not be able perform further tests to the normal output in the normal way until you call C (well, unless you manually meddle with the output filehandles) =cut sub test_out { # do we need to do any setup? _start_testing() unless $testing; $out->expect(@_); } sub test_err { # do we need to do any setup? _start_testing() unless $testing; $err->expect(@_); } =item test_fail Because the standard failure message that L produces whenever a test fails will be a common occurrence in your test error output, and because it has changed between Test::Builder versions, rather than forcing you to call C with the string all the time like so test_err("# Failed test ($0 at line ".line_num(+1).")"); C exists as a convenience function that can be called instead. It takes one argument, the offset from the current line that the line that causes the fail is on. test_fail(+1); This means that the example in the synopsis could be rewritten more simply as: test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); =cut sub test_fail { # do we need to do any setup? _start_testing() unless $testing; # work out what line we should be on my( $package, $filename, $line ) = caller; $line = $line + ( shift() || 0 ); # prevent warnings # expect that on stderr $err->expect("# Failed test ($filename at line $line)"); } =item test_diag As most of the remaining expected output to the error stream will be created by L's C function, L provides a convenience function C that you can use instead of C. The C function prepends comment hashes and spacing to the start and newlines to the end of the expected output passed to it and adds it to the list of expected error output. So, instead of writing test_err("# Couldn't open file"); you can write test_diag("Couldn't open file"); Remember that L's diag function will not add newlines to the end of output and test_diag will. So to check Test::Builder->new->diag("foo\n","bar\n"); You would do test_diag("foo","bar") without the newlines. =cut sub test_diag { # do we need to do any setup? _start_testing() unless $testing; # expect the same thing, but prepended with "# " local $_; $err->expect( map { "# $_" } @_ ); } =item test_test Actually performs the output check testing the tests, comparing the data (with C) that we have captured from L against what was declared with C and C. This takes name/value pairs that affect how the test is run. =over =item title (synonym 'name', 'label') The name of the test that will be displayed after the C or C. =item skip_out Setting this to a true value will cause the test to ignore if the output sent by the test to the output stream does not match that declared with C. =item skip_err Setting this to a true value will cause the test to ignore if the output sent by the test to the error stream does not match that declared with C. =back As a convenience, if only one argument is passed then this argument is assumed to be the name of the test (as in the above examples.) Once C has been run test output will be redirected back to the original filehandles that L was connected to (probably STDOUT and STDERR,) meaning any further tests you run will function normally and cause success/errors for L. =cut sub test_test { # END the hack delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake'; # decode the arguments as described in the pod my $mess; my %args; if( @_ == 1 ) { $mess = shift } else { %args = @_; $mess = $args{name} if exists( $args{name} ); $mess = $args{title} if exists( $args{title} ); $mess = $args{label} if exists( $args{label} ); } # er, are we testing? croak "Not testing. You must declare output with a test function first." unless $testing; my $hub = $t->{Hub} || Test2::API::test2_stack->top; $hub->format($original_formatter); # okay, reconnect the test suite back to the saved handles $t->output($original_output_handle); $t->failure_output($original_failure_handle); $t->todo_output($original_todo_handle); # restore the test no, etc, back to the original point $t->current_test($testing_num); $testing = 0; $t->is_passing($original_is_passing); # re-enable the original setting of the harness $ENV{HARNESS_ACTIVE} = $original_harness_env; # check the output we've stashed unless( $t->ok( ( $args{skip_out} || $out->check ) && ( $args{skip_err} || $err->check ), $mess ) ) { # print out the diagnostic information about why this # test failed local $_; $t->diag( map { "$_\n" } $out->complaint ) unless $args{skip_out} || $out->check; $t->diag( map { "$_\n" } $err->complaint ) unless $args{skip_err} || $err->check; } } =item line_num A utility function that returns the line number that the function was called on. You can pass it an offset which will be added to the result. This is very useful for working out the correct text of diagnostic functions that contain line numbers. Essentially this is the same as the C<__LINE__> macro, but the C idiom is arguably nicer. =cut sub line_num { my( $package, $filename, $line ) = caller; return $line + ( shift() || 0 ); # prevent warnings } =back In addition to the six exported functions there exists one function that can only be accessed with a fully qualified function call. =over 4 =item color When C is called and the output that your tests generate does not match that which you declared, C will print out debug information showing the two conflicting versions. As this output itself is debug information it can be confusing which part of the output is from C and which was the original output from your original tests. Also, it may be hard to spot things like extraneous whitespace at the end of lines that may cause your test to fail even though the output looks similar. To assist you C can colour the background of the debug information to disambiguate the different types of output. The debug output will have its background coloured green and red. The green part represents the text which is the same between the executed and actual output, the red shows which part differs. The C function determines if colouring should occur or not. Passing it a true or false value will enable or disable colouring respectively, and the function called with no argument will return the current setting. To enable colouring from the command line, you can use the L module like so: perl -Mlib=Text::Builder::Tester::Color test.t Or by including the L module directly in the PERL5LIB. =cut my $color; sub color { $color = shift if @_; $color; } =back =head1 BUGS Test::Builder::Tester does not handle plans well. It has never done anything special with plans. This means that plans from outside Test::Builder::Tester will affect Test::Builder::Tester, worse plans when using Test::Builder::Tester will affect overall testing. At this point there are no plans to fix this bug as people have come to depend on it, and Test::Builder::Tester is now discouraged in favor of C. See L Calls C<< Test::Builder->no_ending >> turning off the ending tests. This is needed as otherwise it will trip out because we've run more tests than we strictly should have and it'll register any failures we had that we were testing for as real failures. The color function doesn't work unless L is compatible with your terminal. Additionally, L must be installed on windows platforms for color output. Bugs (and requests for new features) can be reported to the author though GitHub: L =head1 AUTHOR Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. Some code taken from L and L, written by Michael G Schwern Eschwern@pobox.comE. Hence, those parts Copyright Micheal G Schwern 2001. Used and distributed with permission. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 NOTES Thanks to Richard Clamp Erichardc@unixbeard.netE for letting me use his testing system to try this module out on. =head1 SEE ALSO L, L, L. =cut 1; #################################################################### # Helper class that is used to remember expected and received data package Test::Builder::Tester::Tie; ## # add line(s) to be expected sub expect { my $self = shift; my @checks = @_; foreach my $check (@checks) { $check = $self->_account_for_subtest($check); $check = $self->_translate_Failed_check($check); push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; } } sub _account_for_subtest { my( $self, $check ) = @_; my $hub = $t->{Stack}->top; my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0; return ref($check) ? $check : (' ' x $nesting) . $check; } sub _translate_Failed_check { my( $self, $check ) = @_; if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; } return $check; } ## # return true iff the expected data matches the got data sub check { my $self = shift; # turn off warnings as these might be undef local $^W = 0; my @checks = @{ $self->{wanted} }; my $got = $self->{got}; foreach my $check (@checks) { $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); return 0 unless $got =~ s/^$check//; } return length $got == 0; } ## # a complaint message about the inputs not matching (to be # used for debugging messages) sub complaint { my $self = shift; my $type = $self->type; my $got = $self->got; my $wanted = join '', @{ $self->wanted }; # are we running in colour mode? if(Test::Builder::Tester::color) { # get color eval { require Term::ANSIColor }; unless($@) { eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms # colours my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red"); my $reset = Term::ANSIColor::color("reset"); # work out where the two strings start to differ my $char = 0; $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); # get the start string and the two end strings my $start = $green . substr( $wanted, 0, $char ); my $gotend = $red . substr( $got, $char ) . $reset; my $wantedend = $red . substr( $wanted, $char ) . $reset; # make the start turn green on and off $start =~ s/\n/$reset\n$green/g; # make the ends turn red on and off $gotend =~ s/\n/$reset\n$red/g; $wantedend =~ s/\n/$reset\n$red/g; # rebuild the strings $got = $start . $gotend; $wanted = $start . $wantedend; } } my @got = split "\n", $got; my @wanted = split "\n", $wanted; $got = ""; $wanted = ""; while (@got || @wanted) { my $g = shift @got || ""; my $w = shift @wanted || ""; if ($g ne $w) { if($g =~ s/(\s+)$/ |> /g) { $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1; } if($w =~ s/(\s+)$/ |> /g) { $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1; } $g = "> $g"; $w = "> $w"; } else { $g = " $g"; $w = " $w"; } $got = $got ? "$got\n$g" : $g; $wanted = $wanted ? "$wanted\n$w" : $w; } return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; } ## # forget all expected and got data sub reset { my $self = shift; %$self = ( type => $self->{type}, got => '', wanted => [], ); } sub got { my $self = shift; return $self->{got}; } sub wanted { my $self = shift; return $self->{wanted}; } sub type { my $self = shift; return $self->{type}; } ### # tie interface ### sub PRINT { my $self = shift; $self->{got} .= join '', @_; } sub TIEHANDLE { my( $class, $type ) = @_; my $self = bless { type => $type }, $class; $self->reset; return $self; } sub READ { } sub READLINE { } sub GETC { } sub FILENO { } 1; Module.pm100644001750001750 775714772042322 21373 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Builderpackage Test::Builder::Module; use strict; use Test::Builder; require Exporter; our @ISA = qw(Exporter); our $VERSION = '1.302210'; =head1 NAME Test::Builder::Module - Base class for test modules =head1 SYNOPSIS # Emulates Test::Simple package Your::Module; my $CLASS = __PACKAGE__; use parent 'Test::Builder::Module'; @EXPORT = qw(ok); sub ok ($;$) { my $tb = $CLASS->builder; return $tb->ok(@_); } 1; =head1 DESCRIPTION This is a superclass for L-based modules. It provides a handful of common functionality and a method of getting at the underlying L object. =head2 Importing Test::Builder::Module is a subclass of L which means your module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... all act normally. A few methods are provided to do the C<< use Your::Module tests => 23 >> part for you. =head3 import Test::Builder::Module provides an C method which acts in the same basic way as L's, setting the plan and controlling exporting of functions and variables. This allows your module to set the plan independent of L. All arguments passed to C are passed onto C<< Your::Module->builder->plan() >> with the exception of C<< import =>[qw(things to import)] >>. use Your::Module import => [qw(this that)], tests => 23; says to import the functions C and C as well as set the plan to be 23 tests. C also sets the C attribute of your builder to be the caller of the C function. Additional behaviors can be added to your C method by overriding C. =cut sub import { my($class) = shift; Test2::API::test2_load() unless Test2::API::test2_in_preload(); # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; my $test = $class->builder; my $caller = caller; $test->exported_to($caller); $class->import_extra( \@_ ); my(@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; $class->Exporter::import(@imports); } sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'import' ) { push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { push @other, $item; } $idx++; } @$list = @other; return @imports; } =head3 import_extra Your::Module->import_extra(\@import_args); C is called by C. It provides an opportunity for you to add behaviors to your module based on its import list. Any extra arguments which shouldn't be passed on to C should be stripped off by this method. See L for an example of its use. B This mechanism is I as it feels like a bit of an ugly hack in its current form. =cut sub import_extra { } =head2 Builder Test::Builder::Module provides some methods of getting at the underlying Test::Builder object. =head3 builder my $builder = Your::Class->builder; This method returns the L object associated with Your::Class. It is not a constructor so you can call it as often as you like. This is the preferred way to get the L object. You should I get it via C<< Test::Builder->new >> as was previously recommended. The object returned by C may change at runtime so you should call C inside each function rather than store it in a global. sub ok { my $builder = Your::Class->builder; return $builder->ok(@_); } =cut sub builder { return Test::Builder->new; } =head1 SEE ALSO L<< Test2::Manual::Tooling::TestBuilder >> describes the improved options for writing testing modules provided by L<< Test2 >>. =cut 1; Build.t100644001750001750 14414772042322 21445 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Workflowuse Test2::Bundle::Extended -target => 'Test2::Workflow::Build'; skip_all "Tests not yet written"; Encoding.t100644001750001750 205014772042322 21440 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Warnings.t100644001750001750 373514772042322 21515 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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 'blah 1' }, "warnings"); my $es = intercept { ok(!no_warnings { warn "blah 2\n" }, "warnings 1"); ok(no_warnings { warn "blah 3\n" }, "warnings 2") }; like( [grep { $_->isa('Test2::Event::Diag') } @$es], [ {message => qr/Failed test 'warnings 2'/}, {message => "blah 3\n"}, ], "When the test failed we got a diag about the warning, but we got no diag when it passed" ); 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 { scalar 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." ); like( warning { warns { 1 } }, qr/Useless use of warns\(\) in void context/, "warns in void context" ); like( warning { warning { 1 } }, qr/Useless use of warning\(\) in void context/, "warns in void context" ); like( warning { warnings { 1 } }, qr/Useless use of warnings\(\) in void context/, "warns in void context" ); like( warning { no_warnings { 1 } }, qr/Useless use of no_warnings\(\) in void context/, "warns in void context" ); done_testing; Scalar.t100644001750001750 177014772042322 21415 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; String.t100644001750001750 771614772042322 21464 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Custom.t100644001750001750 317714772042322 21465 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Object.t100644001750001750 1731514772042322 21440 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Number.t100644001750001750 546414772042322 21444 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Module.t100644001750001750 77314772042322 21445 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse 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; EnvVar.t100644001750001750 63514772042322 21416 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse Test2::Bundle::Extended -target => 'Test2::Require::EnvVar'; { local $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; 478-cmp_ok_hash.t100644001750001750 163314772042322 21147 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use warnings; use Test::More; my $want = 0; my $got = 0; cmp_ok($got, 'eq', $want, "Passes on correct comparison"); my ($res, @ok, @diag, @warn); { no warnings 'redefine'; local *Test::Builder::ok = sub { my ($tb, $ok, $name) = @_; push @ok => $ok; return $ok; }; local *Test::Builder::diag = sub { my ($tb, @d) = @_; push @diag => @d; }; local $SIG{__WARN__} = sub { push @warn => @_; }; $res = cmp_ok($got, '#eq', $want, "You shall not pass!"); } ok(!$res, "Did not pass"); is(@ok, 1, "1 result"); ok(!$ok[0], "result is false"); # We only care that it mentions a syntax error. like(join("\n" => @diag), qr/syntax error at \(eval in cmp_ok\)/, "Syntax error"); # We are not going to inspect the warning because it is not super predictable, # and changes with eval specifics. ok(@warn, "We got warnings"); done_testing; Tester000755001750001750 014772042322 17272 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacytbt_09do.t100644001750001750 113314772042322 21241 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl use strict; use warnings; use Test::Builder::Tester tests => 3; use Test::More; use File::Basename qw(dirname); use File::Spec qw(); my $file = File::Spec->join(dirname(__FILE__), 'tbt_09do_script.pl'); $file = File::Spec->rel2abs(File::Spec->catfile(File::Spec->curdir(), $file)) unless File::Spec->file_name_is_absolute($file); my $done = do $file; ok(defined($done), 'do succeeded') or do { if ($@) { diag qq( \$@ is '$@'\n); } elsif ($!) { diag qq( \$! is '$!'\n); } else { diag qq( file's last statement returned undef: $file) } }; threads.t100644001750001750 65614772042322 21463 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w use strict; use warnings; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; use Test::More; subtest 'simple test with threads on' => sub { is( 1+1, 2, "simple test" ); is( "a", "a", "another simple test" ); }; pass("Parent retains sharedness"); done_testing(2); details.t100644001750001750 577614772042322 21403 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # HARNESS-NO-STREAM BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More; use Test::Builder; my $Test = Test::Builder->new; $Test->plan( tests => 9 ); $Test->level(0); my @Expected_Details; $Test->is_num( scalar $Test->summary(), 0, 'no tests yet, no summary' ); push @Expected_Details, { 'ok' => 1, actual_ok => 1, name => 'no tests yet, no summary', type => '', reason => '' }; # Inline TODO tests will confuse pre 1.20 Test::Harness, so we # should just avoid the problem and not print it out. my $start_test = $Test->current_test + 1; my $output = ''; $Test->output(\$output); $Test->todo_output(\$output); SKIP: { $Test->skip( 'just testing skip' ); } push @Expected_Details, { 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => 'just testing skip', }; TODO: { local $TODO = 'i need a todo'; $Test->ok( 0, 'a test to todo!' ); push @Expected_Details, { 'ok' => 1, actual_ok => 0, name => 'a test to todo!', type => 'todo', reason => 'i need a todo', }; $Test->todo_skip( 'i need both' ); } push @Expected_Details, { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => 'i need both' }; for ($start_test..$Test->current_test) { print "ok $_\n" } $Test->reset_outputs; $Test->is_num( scalar $Test->summary(), 4, 'summary' ); push @Expected_Details, { 'ok' => 1, actual_ok => 1, name => 'summary', type => '', reason => '', }; $Test->current_test(6); print "ok 6 - current_test incremented\n"; push @Expected_Details, { 'ok' => 1, actual_ok => undef, name => undef, type => 'unknown', reason => 'incrementing test number', }; my @details = $Test->details(); $Test->is_num( scalar @details, 6, 'details() should return a list of all test details'); $Test->level(1); is_deeply( \@details, \@Expected_Details ); # This test has to come last because it thrashes the test details. { my $curr_test = $Test->current_test; $Test->current_test(4); my @details = $Test->details(); $Test->current_test($curr_test); $Test->is_num( scalar @details, 4 ); } no_diag.t100644001750001750 46614772042322 21325 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w use Test::More 'no_diag'; plan 'skip_all' => "This test cannot be run with the current formatter" unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); pass('foo'); diag('This should not be displayed'); is(Test::More->builder->no_diag, 1); done_testing; Builder.t100644001750001750 121714772042322 21326 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # HARNESS-NO-STREAM BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::Builder; my $Test = Test::Builder->new; $Test->plan( tests => 7 ); my $default_lvl = $Test->level; $Test->level(0); $Test->ok( 1, 'compiled and new()' ); $Test->ok( $default_lvl == 1, 'level()' ); $Test->is_eq('foo', 'foo', 'is_eq'); $Test->is_num('23.0', '23', 'is_num'); $Test->is_num( $Test->current_test, 4, 'current_test() get' ); my $test_num = $Test->current_test + 1; $Test->current_test( $test_num ); print "ok $test_num - current_test() set\n"; $Test->ok( 1, 'counter still good' ); Event000755001750001750 014772042322 20352 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesOk.t100644001750001750 1053514772042322 21274 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; use Test2::Event::Ok; use Test2::Event::Diag; use Test2::API qw/context/; my $trace; sub before_each { # Make sure there is a fresh trace object for each group $trace = Test2::EventFacet::Trace->new( frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], ); } tests Passing => sub { my $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, name => 'the_test', ); ok($ok->increments_count, "Bumps the count"); ok(!$ok->causes_fail, "Passing 'OK' event does not cause failure"); is($ok->pass, 1, "got pass"); is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 1, "effective pass"); is($ok->summary, "the_test", "Summary is just the name of the test"); my $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); ok(!$facet_data->{amnesty}, "No amnesty by default"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 1, details => 'the_test', }, "Got assert facet", ); $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, name => '', ); is($ok->summary, "Nameless Assertion", "Nameless test"); $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); ok(!$facet_data->{amnesty}, "No amnesty by default"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 1, details => '', }, "Got assert facet", ); }; tests Failing => sub { local $ENV{HARNESS_ACTIVE} = 1; local $ENV{HARNESS_IS_VERBOSE} = 1; my $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, name => 'the_test', ); ok($ok->increments_count, "Bumps the count"); ok($ok->causes_fail, "A failing test causes failures"); is($ok->pass, 0, "got pass"); is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 0, "effective pass"); is($ok->summary, "the_test", "Summary is just the name of the test"); my $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); ok(!$facet_data->{amnesty}, "No amnesty by default"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 0, details => 'the_test', }, "Got assert facet", ); }; tests "Failing TODO" => sub { local $ENV{HARNESS_ACTIVE} = 1; local $ENV{HARNESS_IS_VERBOSE} = 1; my $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, name => 'the_test', todo => 'A Todo', ); ok($ok->increments_count, "Bumps the count"); is($ok->pass, 0, "got pass"); is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 1, "effective pass is true from todo"); is($ok->summary, "the_test (TODO: A Todo)", "Summary is just the name of the test + todo"); my $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 0, details => 'the_test', }, "Got assert facet", ); is_deeply( $facet_data->{amnesty}, [{ tag => 'TODO', details => 'A Todo', }], "Got amnesty facet", ); $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, name => 'the_test2', todo => '', ); ok($ok->effective_pass, "empty string todo is still a todo"); is($ok->summary, "the_test2 (TODO)", "Summary is just the name of the test + todo"); $facet_data = $ok->facet_data; ok($facet_data->{about}, "got common facet data"); is_deeply( $facet_data->{assert}, { no_debug => 1, pass => 0, details => 'the_test2', }, "Got assert facet", ); is_deeply( $facet_data->{amnesty}, [{ tag => 'TODO', details => '', }], "Got amnesty facet", ); }; tests init => sub { my $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, ); is($ok->effective_pass, 1, "set effective pass"); }; done_testing; V2.t100644001750001750 504114772042322 21166 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/context intercept/; use Test2::Event::V2(); my $CLASS = 'Test2::Event::V2'; ok($CLASS->isa('Test2::Event'), "Subclass of Test2::Event"); is_deeply( [Test2::Event::V2->non_facet_keys], ['uuid', '_meta'], "Got non-facet keys" ); ok($CLASS->can($_), "has method $_") for qw{ causes_fail diagnostics global increments_count no_display sets_plan subtest_id summary terminate uuid set_uuid meta facet_data about }; ok(!exception { $CLASS->new(uuid => 2, about => {uuid => 2}) }, "Can have matching uuids"); like( exception { $CLASS->new(uuid => 1, about => {uuid => 2}) }, qr/uuid '1' passed to constructor, but uuid '2' is already set in the 'about' facet/, "Cannot have a uuid mismatch" ); my $one = $CLASS->new(uuid => 123); is($one->about->{uuid}, 123, "Set uuid in about facet"); $one = $CLASS->new(about => { uuid => 123 }); is($one->uuid, 123, "set uuid attribute"); my $trace = {frame => ['main', 'file.t', 42, 'foo'], tid => 0, pid => $$, stamp => 123}; $one = $CLASS->new(trace => $trace); ok($trace != $one->trace, "Did not keep or modify the original trace ref"); ok($one->trace->isa('Test2::EventFacet::Trace'), "Blessed the trace"); is_deeply($one->trace, $trace, "Trace has all data"); $one = $CLASS->new; ok(!$one->uuid, "no uuid attribute"); ok(!($one->about && $one->about->{uuid}), "no uuid in about facet"); $one->set_uuid(123); is($one->about->{uuid}, 123, "Set uuid in about facet"); is($one->uuid, 123, "set uuid attribute"); $one = $CLASS->new( uuid => '123', trace => $trace, assert => {pass => 1, details => 'pass'}, info => [{tag => 'NOTE', details => 'a note'}], ); $one->set_meta('foo' => {'xyz' => 1}); $one->{_custom_sttr} = 'xxx'; is_deeply( $one->facet_data, { trace => $trace, assert => {pass => 1, details => 'pass'}, info => [{tag => 'NOTE', details => 'a note'}], meta => {foo => {'xyz' => 1}}, about => {uuid => 123}, }, "Facet data has everything we want, and nothing we do not" ); sub my_tool { my $ctx = context(); my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]); $ctx->release; return $event; } my $events = intercept { my_tool(); }; is(@$events, 1, "Got 1 event"); ok($events->[0]->isa($CLASS), "Created the right type of event"); is_deeply( $events->[0]->facet_data->{info}, [{tag => 'NOTE', details => "This is a note"}], "Got the specified info facet" ); done_testing; err_var.t100644001750001750 26114772042322 21364 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; { local $! = 100; is(0 + $!, 100, 'set $!'); is(0 + $!, 100, 'preserved $!'); } done_testing; regression000755001750001750 014772042322 20001 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2gh_16.t100644001750001750 172514772042322 21237 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/regressionuse strict; use warnings; # This test checks for a pretty rare condition, one that was mainly a problem # on 5.20+ (though a 5.8 also had the problem). I am not too worried about this # breaking again. That said I still want it run on newer perls (where it is # less likely to fail for an unrelated reason) and when I have AUTHOR_TESTING # set. BEGIN { unless($ENV{AUTHOR_TESTING} || eval "no warnings 'portable'; require v5.20; 1") { print "1..0 # Skip Crazy test, only run on 5.20+, or when AUTHOR_TESTING is set\n"; exit 0; } } # This test is for gh #16 # Also see https://rt.perl.org/Public/Bug/Display.html?id=127774 # Create this END before anything else so that $? gets set to 0 END { $? = 0 } BEGIN { print "\n1..1\n"; close(STDERR); open(STDERR, '>&STDOUT'); } use Test2::API; eval(' sub { die "xxx" } ')->(); END { sub { my $ctx = Test2::API::context(); $ctx->release; }->(); print "ok 1 - Did not segv\n"; $? = 0; } Simple000755001750001750 014772042322 17536 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/TestCatch.pm100644001750001750 72014772042322 21235 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple# For testing Test::Simple; package Test::Simple::Catch; use strict; use Symbol; use TieOut; my( $out_fh, $err_fh ) = ( gensym, gensym ); my $out = tie *$out_fh, 'TieOut'; my $err = tie *$err_fh, 'TieOut'; use Test::Builder; require Test::Builder::Formatter; my $t = Test::Builder->new; $t->{Stack}->top->format(Test::Builder::Formatter->new); $t->output($out_fh); $t->failure_output($err_fh); $t->todo_output($err_fh); sub caught { return( $out, $err ) } 1; Build.pm100644001750001750 713314772042322 21477 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Workflowpackage Test2::Workflow::Build; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Encoding.pm100644001750001750 334614772042322 21437 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Encoding; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/encoding/; sub init { my $self = shift; defined $self->{+ENCODING} or croak "'encoding' is a required attribute"; } sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control}->{encoding} = $self->{+ENCODING}; $out->{about}->{details} = $self->summary; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Encoding - Set the encoding for the output stream =head1 DESCRIPTION The encoding event is generated when a test file wants to specify the encoding to be used when formatting its output. This event is intended to be produced by formatter classes and used for interpreting test names, message contents, etc. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Encoding; my $ctx = context(); my $event = $ctx->send_event('Encoding', encoding => 'UTF-8'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $encoding = $e->encoding The encoding being specified. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 EventFacet000755001750001750 014772042322 20150 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Hub.pm100644001750001750 352214772042322 21366 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Hub; use strict; use warnings; our $VERSION = '1.302210'; sub is_list { 1 } sub facet_key { 'hubs' } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{-pid -tid -hid -nested -buffered -uuid -ipc}; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Hub - Facet for the hubs an event passes through. =head1 DESCRIPTION These are a record of the hubs an event passes through. Most recent hub is the first one in the list. =head1 FACET FIELDS =over 4 =item $string = $trace->{details} =item $string = $trace->details() The hub class or subclass =item $int = $trace->{pid} =item $int = $trace->pid() PID of the hub this event was sent to. =item $int = $trace->{tid} =item $int = $trace->tid() The thread ID of the hub the event was sent to. =item $hid = $trace->{hid} =item $hid = $trace->hid() The ID of the hub that the event was send to. =item $huuid = $trace->{huuid} =item $huuid = $trace->huuid() The UUID of the hub that the event was sent to. =item $int = $trace->{nested} =item $int = $trace->nested() How deeply nested the hub was. =item $bool = $trace->{buffered} =item $bool = $trace->buffered() True if the event was buffered and not sent to the formatter independent of a parent (This should never be set when nested is C<0> or C). =back =head1 SOURCE The source code repository for Test2 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 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 Refcount.pm100644001750001750 2106714772042322 21535 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Tools# 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 = '1.302210'; 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; Encoding.pm100644001750001750 304414772042322 21451 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Encoding; use strict; use warnings; use Carp qw/croak/; use Test2::API qw/test2_stack/; use base 'Exporter'; our $VERSION = '1.302210'; 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 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 Warnings.pm100644001750001750 645614772042322 21525 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Warnings; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/carp/; use Test2::API qw/context test2_add_pending_diag/; our @EXPORT = qw/warns warning warnings no_warnings/; use base 'Exporter'; sub warns(&) { my $code = shift; defined wantarray or carp "Useless use of warns() in void context"; my $warnings = 0; local $SIG{__WARN__} = sub { $warnings++ }; $code->(); return $warnings; } sub no_warnings(&) { defined wantarray or carp "Useless use of no_warnings() in void context"; my $warnings = &warnings(@_); return 1 if !@$warnings; test2_add_pending_diag(@$warnings); return 0; } sub warning(&) { my $code = shift; defined wantarray or carp "Useless use of warning() in void context"; 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; defined wantarray or carp "Useless use of warnings() in void context"; 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 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 Object.pm100644001750001750 1411314772042322 21436 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Object; use strict; use warnings; use Test2::Util qw/try/; use Test2::Compare::Meta(); use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Custom.pm100644001750001750 662114772042322 21467 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Custom; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Scalar.pm100644001750001750 376414772042322 21427 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Scalar; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 String.pm100644001750001750 343714772042322 21465 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::String; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Number.pm100644001750001750 615314772042322 21445 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Number; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 EnvVar.pm100644001750001750 237714772042322 21450 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::EnvVar; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Require'; our $VERSION = '1.302210'; 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 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 Module.pm100644001750001750 466614772042322 21477 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::Module; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; 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 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 Manual000755001750001750 014772042322 17341 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Testing.pm100644001750001750 1235414772042322 21501 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manualpackage Test2::Manual::Testing; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Tooling.pm100644001750001750 474014772042322 21457 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manualpackage Test2::Manual::Tooling; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Anatomy.pm100644001750001750 336714772042322 21460 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manualpackage Test2::Manual::Anatomy; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Delegate.pm100644001750001750 105014772042322 21514 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Testeruse strict; use warnings; package Test::Tester::Delegate; our $VERSION = '1.302210'; use Scalar::Util(); sub new { my $pkg = shift; my $obj = shift; my $self = bless {}, $pkg; return $self; } sub AUTOLOAD { my ($sub) = our $AUTOLOAD =~ /.*::(.*?)$/; return if $sub eq "DESTROY"; my $obj = $_[0]->{Object}; my $ref = $obj->can($sub); shift(@_); unshift(@_, $obj); goto &$ref; } sub can { my $this = shift; my ($sub) = @_; return $this->{Object}->can($sub) if Scalar::Util::blessed($this); return $this->SUPER::can(@_); } 1; Runner.t100644001750001750 14514772042322 21660 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Workflowuse Test2::Bundle::Extended -target => 'Test2::Workflow::Runner'; skip_all "Tests not yet written"; Table000755001750001750 014772042322 20234 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/UtilCell.t100644001750001750 306214772042322 21441 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Util/Tableuse 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; Exception.t100644001750001750 215214772042322 21653 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; Extended.t100644001750001750 513414772042322 21571 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Bundleuse 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; Pattern.t100644001750001750 243114772042322 21620 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; Threads.t100644001750001750 101714772042322 21622 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse 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; overload_threads.t100644001750001750 223214772042322 21675 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!perl -w use Test2::Util qw/CAN_THREAD/; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } chdir 't'; BEGIN { # There was a bug with overloaded objects and threads. # See rt.cpan.org 4218 eval { require threads; 'threads'->import; 1; } if CAN_THREAD; } use Test::More; plan skip_all => "known to crash on $]" if "$]" <= 5.006002; plan tests => 5; package Overloaded; use overload q{""} => sub { $_[0]->{string} }; sub new { my $class = shift; bless { string => shift }, $class; } package main; my $warnings = ''; local $SIG{__WARN__} = sub { $warnings = join '', @_ }; # overloaded object as name my $obj = Overloaded->new('foo'); ok( 1, $obj ); # overloaded object which returns undef as name my $undef = Overloaded->new(undef); pass( $undef ); is( $warnings, '' ); TODO: { my $obj = Overloaded->new('not really todo, testing overloaded reason'); local $TODO = $obj; fail("Just checking todo as an overloaded value"); } SKIP: { my $obj = Overloaded->new('not really skipped, testing overloaded reason'); skip $obj, 1; } BEGIN_require_ok.t100644001750001750 71714772042322 21407 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # Fixed a problem with BEGIN { use_ok or require_ok } silently failing when there's no # plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak. use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::More; my $result; BEGIN { $result = require_ok("strict"); } ok $result, "require_ok ran"; done_testing(2); explain_err_vars.t100644001750001750 17214772042322 21674 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacyuse strict; use warnings; use Test::More; $@ = 'foo'; explain { 1 => 1 }; is($@, 'foo', "preserved \$@"); done_testing; tbt_03die.t100644001750001750 34114772042322 21352 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl use Test::Builder::Tester tests => 1; use Test::More; eval { test_test("foo"); }; like($@, "/Not testing\. You must declare output with a test function first\./", "dies correctly on error"); bail_out.t100644001750001750 240014772042322 21634 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } my $goto = 0; my $Exit_Code; BEGIN { *CORE::GLOBAL::exit = sub { $Exit_Code = shift; goto XXX if $goto; CORE::exit($Exit_Code)}; } use Test::Builder; use Test::More; my $skip = ref(Test::Builder->new->{Stack}->top->format) ne 'Test::Builder::Formatter'; plan skip_all => "This test cannot be run with the current formatter" if $skip; $goto = 1; my $output; my $TB = Test::More->builder; $TB->output(\$output); my $Test = Test::Builder->create; $Test->level(0); $Test->plan(tests => 2); plan tests => 4; ok 'foo'; subtest 'bar' => sub { plan tests => 3; ok 'sub_foo'; subtest 'sub_bar' => sub { plan tests => 3; ok 'sub_sub_foo'; ok 'sub_sub_bar'; BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); ok 'sub_sub_baz'; }; ok 'sub_baz'; }; XXX: $Test->is_eq( $output, <<'OUT' ); 1..4 ok 1 # Subtest: bar 1..3 ok 1 # Subtest: sub_bar 1..3 ok 1 ok 2 Bail out! ROCKS FALL! EVERYONE DIES! OUT $Test->is_eq( $Exit_Code, 255 ); Test2::API::test2_stack()->top->set_no_ending(1); callback.t100644001750001750 177014772042322 21603 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # What happens when a subtest dies? use lib 't/lib'; use strict; use Test::More; use Test::Builder; use Test2::API; my $Test = Test::Builder->new; my $step = 0; my @callback_calls = (); Test2::API::test2_add_callback_pre_subtest( sub { $Test->is_num( $step, 0, 'pre-subtest callbacks should be invoked before the subtest', ); ++$step; push @callback_calls, [@_]; }, ); $Test->subtest( (my $subtest_name='some subtest'), (my $subtest_code=sub { $Test->is_num( $step, 1, 'subtest should be run after the pre-subtest callbacks', ); ++$step; }), (my @subtest_args = (1,2,3)), ); is_deeply( \@callback_calls, [[$subtest_name,$subtest_code,@subtest_args]], 'pre-subtest callbacks should be invoked with the expected arguments', ); $Test->is_num( $step, 2, 'the subtest should be run', ); $Test->done_testing(); has_plan.t100644001750001750 55614772042322 21512 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib'); } } use strict; use Test::Builder; my $unplanned; BEGIN { $unplanned = 'oops'; $unplanned = Test::Builder->new->has_plan; }; use Test::More tests => 2; is($unplanned, undef, 'no plan yet defined'); is(Test::Builder->new->has_plan, 2, 'has fixed plan'); errors_facet.t100644001750001750 173214772042322 22006 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::Tools::Tiny; use Test2::API qw/intercept context/; { $INC{'My/Event.pm'} = 1; package My::Event; use base 'Test2::Event'; use Test2::Util::Facets2Legacy ':ALL'; sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{errors} = [{tag => 'OOPS', fail => !$ENV{FAILURE_DO_PASS}, details => "An error occurred"}]; return $out; } } sub error { my $ctx = context(); my $e = $ctx->send_event('+My::Event'); $ctx->release; return $e; } my $events = intercept { tests foo => sub { ok(1, "need at least 1 assertion"); error(); }; }; ok(!$events->[0]->pass, "Subtest did not pass"); my ($passing_a, $passing_b); intercept { my $hub = Test2::API::test2_stack->top; $passing_a = $hub->is_passing; error(); $passing_b = $hub->is_passing; }; ok($passing_a, "Passign before error"); ok(!$passing_b, "Not passing after error"); done_testing; API000755001750001750 014772042322 17702 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesStack.t100644001750001750 350114772042322 21273 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/APIuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API::Stack; use Test2::API qw/test2_ipc/; ok(my $stack = Test2::API::Stack->new, "Create a stack"); ok(!@$stack, "Empty stack"); ok(!$stack->peek, "Nothing to peek at"); ok(!exception { $stack->cull }, "cull lives when stack is empty"); ok(!exception { $stack->all }, "all lives when stack is empty"); ok(!exception { $stack->clear }, "clear lives when stack is empty"); like( exception { $stack->pop(Test2::Hub->new) }, qr/No hubs on the stack/, "No hub to pop" ); my $hub = Test2::Hub->new; ok($stack->push($hub), "pushed a hub"); like( exception { $stack->pop($hub) }, qr/You cannot pop the root hub/, "Root hub cannot be popped" ); $stack->push($hub); like( exception { $stack->pop(Test2::Hub->new) }, qr/Hub stack mismatch, attempted to pop incorrect hub/, "Must specify correct hub to pop" ); is_deeply( [ $stack->all ], [ $hub, $hub ], "Got all hubs" ); ok(!exception { $stack->pop($hub) }, "Popped the correct hub"); is_deeply( [ $stack->all ], [ $hub ], "Got all hubs" ); is($stack->peek, $hub, "got the hub"); is($stack->top, $hub, "got the hub"); $stack->clear; is_deeply( [ $stack->all ], [ ], "no hubs" ); ok(my $top = $stack->top, "Generated a top hub"); is($top->ipc, test2_ipc, "Used sync's ipc"); ok($top->format, 'Got formatter'); is($stack->top, $stack->top, "do not generate a new top if there is already a top"); ok(my $new = $stack->new_hub(), "Add a new hub"); is($stack->top, $new, "new one is on top"); is($new->ipc, $top->ipc, "inherited ipc"); is($new->format, $top->format, "inherited formatter"); my $new2 = $stack->new_hub(formatter => undef, ipc => undef); ok(!$new2->ipc, "built with no ipc"); ok(!$new2->format, "built with no formatter"); done_testing; Runner.pm100644001750001750 3107214772042322 21730 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Workflowpackage Test2::Workflow::Runner; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Exception.pm100644001750001750 336214772042322 21645 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Eventpackage Test2::Event::Exception; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{error}; sub init { my $self = shift; $self->{+ERROR} = "$self->{+ERROR}"; } sub causes_fail { 1 } sub summary { my $self = shift; chomp(my $msg = "Exception: " . $self->{+ERROR}); return $msg; } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{errors} = [ { tag => 'ERROR', fail => 1, details => $self->{+ERROR}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Exception - Exception event =head1 DESCRIPTION An exception event will display to STDERR, and will prevent the overall test file from passing. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Exception; my $ctx = context(); my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $reason = $e->error The reason for the exception. =back =head1 CAVEATS Be aware that all exceptions are stringified during construction. =head1 SOURCE The source code repository for Test2 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 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 Table000755001750001750 014772042322 20070 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/UtilCell.pm100644001750001750 17314772042322 21426 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Util/Tablepackage Test2::Util::Table::Cell; use strict; use warnings; our $VERSION = '1.302210'; use base 'Term::Table::Cell'; 1; Plan.pm100644001750001750 353314772042322 21544 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Plan; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -count -skip -none }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Plan - Facet for setting the plan =head1 DESCRIPTION Events use this facet when they need to set the plan. =head1 FIELDS =over 4 =item $string = $plan->{details} =item $string = $plan->details() Human readable explanation for the plan being set. This is normally not rendered by most formatters except when the C field is also set. =item $positive_int = $plan->{count} =item $positive_int = $plan->count() Set the number of expected assertions. This should usually be set to C<0> when C or C are also set. =item $bool = $plan->{skip} =item $bool = $plan->skip() When true the entire test should be skipped. This is usually paired with an explanation in the C
field, and a C facet that has C set to C<0>. =item $bool = $plan->{none} =item $bool = $plan->none() This is mainly used by legacy L tests which set the plan to C, a construct that predates the much better C. If you are using this in non-legacy code you may need to reconsider the course of your life, maybe a hermitage would suite you? =back =head1 SOURCE The source code repository for Test2 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 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 Meta.pm100644001750001750 345714772042322 21545 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Meta; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } # replace set_details { no warnings 'redefine'; sub set_details { $_[0]->{'set_details'} } } sub can { my $self = shift; my ($name) = @_; my $existing = $self->SUPER::can($name); return $existing if $existing; # Only vivify when called on an instance, do not vivify for a class. There # are a lot of magic class methods used in things like serialization (or # the forks.pm module) which cause problems when vivified. return undef unless ref($self); my $sub = sub { $_[0]->{$name} }; { no strict 'refs'; *$name = $sub; } return $sub; } sub AUTOLOAD { my $name = our $AUTOLOAD; $name =~ s/^.*:://g; my $sub = $_[0]->can($name); goto &$sub; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Meta - Facet for meta-data =head1 DESCRIPTION This facet can contain any random meta-data that has been attached to the event. =head1 METHODS AND FIELDS Any/all fields and accessors are autovivified into existence. There is no way to know what metadata may be added, so any is allowed. =over 4 =item $anything = $meta->{anything} =item $anything = $meta->anything() =back =head1 SOURCE The source code repository for Test2 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 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 Info.pm100644001750001750 606314772042322 21546 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Info; use strict; use warnings; our $VERSION = '1.302210'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{-tag -debug -important -table}; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Info - Facet for information a developer might care about. =head1 DESCRIPTION This facet represents messages intended for humans that will help them either understand a result, or diagnose a failure. =head1 NOTES This facet appears in a list instead of being a single item. =head1 FIELDS =over 4 =item $string_or_structure = $info->{details} =item $string_or_structure = $info->details() Human readable string or data structure, this is the information to display. Formatters are free to render the structures however they please. This may contain a blessed object. If the C
attribute (see below) is set then a renderer may choose to display the table instead of the details. =item $structure = $info->{table} =item $structure = $info->table() If the data the C facet needs to convey can be represented as a table then the data may be placed in this attribute in a more raw form for better display. The data must also be represented in the C
attribute for renderers which do not support rendering tables directly. The table structure: my %table = { header => [ 'column 1 header', 'column 2 header', ... ], # Optional rows => [ ['row 1 column 1', 'row 1, column 2', ... ], ['row 2 column 1', 'row 2, column 2', ... ], ... ], # Allow the renderer to hide empty columns when true, Optional collapse => $BOOL, # List by name or number columns that should never be collapsed no_collapse => \@LIST, } =item $short_string = $info->{tag} =item $short_string = $info->tag() Short tag to categorize the info. This is usually 10 characters or less, formatters may truncate longer tags. =item $bool = $info->{debug} =item $bool = $info->debug() Set this to true if the message is critical, or explains a failure. This is info that should be displayed by formatters even in less-verbose modes. When false the information is not considered critical and may not be rendered in less-verbose modes. =item $bool = $info->{important} =item $bool = $info->important This should be set for non debug messages that are still important enough to show when a formatter is in quiet mode. A formatter should send these to STDOUT not STDERR, but should show them even in non-verbose mode. =back =head1 SOURCE The source code repository for Test2 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 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 Exception.pm100644001750001750 760214772042322 21665 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::Exception; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/carp/; use Test2::API qw/context test2_add_pending_diag test2_clear_pending_diags/; 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 = $@; } test2_add_pending_diag("Exception: $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 = $@; my @diag = test2_clear_pending_diags(); # 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(); $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 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 Extended.pm100644001750001750 1677314772042322 21631 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Bundlepackage Test2::Bundle::Extended; use strict; use warnings; use Test2::V0; our $VERSION = '1.302210'; 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 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 Pattern.pm100644001750001750 325214772042322 21627 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Pattern; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 DeepRef.pm100644001750001750 367714772042322 21537 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::DeepRef; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 Threads.pm100644001750001750 413014772042322 21626 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::Threads; use strict; use warnings; BEGIN { require Test2::Require; our @ISA = qw(Test2::Require) } our $VERSION = '1.302210'; 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 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 Interceptor.pm100644001750001750 524314772042322 21642 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Hubpackage Test2::Hub::Interceptor; use strict; use warnings; our $VERSION = '1.302210'; use Test2::Hub::Interceptor::Terminator(); BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; sub init { my $self = shift; $self->SUPER::init(); $self->{+NESTED} = 0; } sub inherit { my $self = shift; my ($from, %params) = @_; $self->{+NESTED} = 0; if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } if (my $ls = $from->{+_LISTENERS}) { push @{$self->{+_LISTENERS}} => grep { $_->{intercept_inherit} } @$ls; } if (my $pfs = $from->{+_PRE_FILTERS}) { push @{$self->{+_PRE_FILTERS}} => grep { $_->{intercept_inherit} } @$pfs; } if (my $fs = $from->{+_FILTERS}) { push @{$self->{+_FILTERS}} => grep { $_->{intercept_inherit} } @$fs; } } sub clean_inherited { my $self = shift; my %params = @_; my @sets = ( $self->{+_LISTENERS}, $self->{+_PRE_FILTERS}, $self->{+_FILTERS}, ); for my $set (@sets) { next unless $set; for my $i (@$set) { my $cbs = $i->{intercept_inherit} or next; next unless ref($cbs) eq 'HASH'; my $cb = $cbs->{clean} or next; $cb->(%params); } } } sub restore_inherited { my $self = shift; my %params = @_; my @sets = ( $self->{+_FILTERS}, $self->{+_PRE_FILTERS}, $self->{+_LISTENERS}, ); for my $set (@sets) { next unless $set; for my $i (@$set) { my $cbs = $i->{intercept_inherit} or next; next unless ref($cbs) eq 'HASH'; my $cb = $cbs->{restore} or next; $cb->(%params); } } } sub terminate { my $self = shift; my ($code) = @_; eval { no warnings 'exiting'; last T2_SUBTEST_WRAPPER; }; my $err = $@; # Fallback die bless(\$err, 'Test2::Hub::Interceptor::Terminator'); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor - Hub used by interceptor to grab results. =head1 SOURCE The source code repository for Test2 can be found at 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 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 TodoDiag.pm100644001750001750 206614772042322 21624 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Builderpackage Test::Builder::TodoDiag; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } sub diagnostics { 0 } sub facet_data { my $self = shift; my $out = $self->SUPER::facet_data(); $out->{info}->[0]->{debug} = 0; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag =head1 DESCRIPTION This is used to encapsulate diag messages created inside TODO. =head1 SYNOPSIS You do not need to use this directly. =head1 SOURCE The source code repository for Test2 can be found at 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 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 AsyncSubtest000755001750001750 014772042322 20717 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modulesHub.t100644001750001750 32214772042322 21737 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/AsyncSubtestuse 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; Wildcard.t100644001750001750 75314772042322 21721 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; DieOnFail.t100644001750001750 232014772042322 21642 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Pluginuse 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; RealFork.t100644001750001750 102514772042322 21734 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse 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; no_done_testing.t100644001750001750 101314772042322 22115 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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 no_leaks_no_iso.t100644001750001750 133614772042322 22110 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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; is_deeply_dne_bug.t100644001750001750 156714772042322 22022 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # test for rt.cpan.org 20768 # # There was a bug where the internal "does not exist" object could get # confused with an overloaded object. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test::More tests => 2; { package Foo; use overload 'eq' => \&overload_equiv, '==' => \&overload_equiv; sub new { return bless {}, shift; } sub overload_equiv { if (ref($_[0]) ne 'Foo' || ref($_[1]) ne 'Foo') { print ref($_[0]), " ", ref($_[1]), "\n"; die "Invalid object passed to overload_equiv\n"; } return 1; # change to 0 ... makes little difference } } my $obj1 = Foo->new(); my $obj2 = Foo->new(); eval { is_deeply([$obj1, $obj2], [$obj1, $obj2]); }; is $@, ''; tbt_07args.t100644001750001750 1223414772042322 21615 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl -w use Test::More tests => 18; use Symbol; use Test::Builder; use Test::Builder::Tester; use strict; # argh! now we need to test the thing we're testing. Basically we need # to pretty much reimplement the whole code again. This is very # annoying but can't be avoided. And onward with the cut and paste # My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING # create some private file handles my $output_handle = gensym; my $error_handle = gensym; # and tie them to this package my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; # ooooh, use the test suite my $t = Test::Builder->new; # remember the testing outputs my $original_output_handle; my $original_failure_handle; my $original_todo_handle; my $testing_num; my $original_harness_env; sub start_testing { # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); $original_todo_handle = $t->todo_output(); $original_harness_env = $ENV{HARNESS_ACTIVE}; # switch out to our own handles $t->output($output_handle); $t->failure_output($error_handle); $t->todo_output($error_handle); $ENV{HARNESS_ACTIVE} = 0; # clear the expected list $out->reset(); $err->reset(); # remember that we're testing $testing_num = $t->current_test; $t->current_test(0); } # each test test is actually two tests. This is bad and wrong # but makes blood come out of my ears if I don't at least simplify # it a little this way sub my_test_test { my $text = shift; local $^W = 0; # reset the outputs $t->output($original_output_handle); $t->failure_output($original_failure_handle); $t->todo_output($original_todo_handle); $ENV{HARNESS_ACTIVE} = $original_harness_env; # reset the number of tests $t->current_test($testing_num); # check we got the same values my $got; my $wanted; # stdout $t->ok($out->check, "STDOUT $text"); # stderr $t->ok($err->check, "STDERR $text"); } #################################################################### # Meta meta tests #################################################################### # this is a quick test to check the hack that I've just implemented # actually does a cut down version of Test::Builder::Tester start_testing(); $out->expect("ok 1 - foo"); pass("foo"); my_test_test("basic meta meta test"); start_testing(); $out->expect("not ok 1 - foo"); $err->expect("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); my_test_test("basic meta meta test 2"); start_testing(); $out->expect("ok 1 - bar"); test_out("ok 1 - foo"); pass("foo"); test_test("bar"); my_test_test("meta meta test with tbt"); start_testing(); $out->expect("ok 1 - bar"); test_out("not ok 1 - foo"); test_err("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); test_test("bar"); my_test_test("meta meta test with tbt2 "); #################################################################### # Actual meta tests #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("ok 1 - foo"); # the actual test function that we are testing ok("1","foo"); # test the name test_test(name => "bar"); # check that passed my_test_test("meta test name"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("ok 1 - foo"); # the actual test function that we are testing ok("1","foo"); # test the name test_test(title => "bar"); # check that passed my_test_test("meta test title"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("ok 1 - foo"); # the actual test function that we are testing ok("1","foo"); # test the name test_test(label => "bar"); # check that passed my_test_test("meta test title"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("not ok 1 - foo this is wrong"); test_fail(+3); # the actual test function that we are testing ok("0","foo"); # test that we got what we expect, ignoring our is wrong test_test(skip_out => 1, name => "bar"); # check that that passed my_test_test("meta test skip_out"); #################################################################### # set up the outer wrapper again start_testing(); $out->expect("ok 1 - bar"); # set up what the inner wrapper expects test_out("not ok 1 - foo"); test_err("this is wrong"); # the actual test function that we are testing ok("0","foo"); # test that we got what we expect, ignoring err is wrong test_test(skip_err => 1, name => "bar"); # diagnostics failing out # check that that passed my_test_test("meta test skip_err"); #################################################################### singleton.t100644001750001750 131014772042322 22037 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More tests => 3; { package Test::Singleton; use Test::Builder; my $TB = Test::Builder->new; sub singleton_ok ($;$) { my( $val, $name ) = @_; $TB->ok( $val, $name ); } } ok 1, 'TB top level'; subtest 'doing a subtest' => sub { plan tests => 4; ok 1, 'first test in subtest'; Test::Singleton::singleton_ok(1, 'this should not fail'); ok 1, 'second test in subtest'; Test::Singleton::singleton_ok(1, 'this should not fail'); }; ok 1, 'left subtest'; predicate.t100644001750001750 1135414772042322 22026 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # Test the use of subtest() to define new test predicates that combine # multiple existing predicates. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More tests => 5; use Test::Builder; use Test::Builder::Tester; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; our %line; # Define a new test predicate with Test::More::subtest(), using # Test::More predicates as building blocks... sub foobar_ok ($;$) { my ($value, $name) = @_; $name ||= "foobar_ok"; local $Test::Builder::Level = $Test::Builder::Level + 1; subtest $name => sub { plan tests => 2; ok $value =~ /foo/, "foo"; ok $value =~ /bar/, "bar"; BEGIN{ $line{foobar_ok_bar} = __LINE__ } }; } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{foobar_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); foobar_ok "foot", "namehere"; test_test("foobar_ok failing line numbers"); } # Wrap foobar_ok() to make another new predicate... sub foobar_ok_2 ($;$) { my ($value, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; foobar_ok($value, $name); } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{foobar_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); foobar_ok_2 "foot", "namehere"; test_test("foobar_ok_2 failing line numbers"); } # Define another new test predicate, this time using # Test::Builder::subtest() rather than Test::More::subtest()... sub barfoo_ok ($;$) { my ($value, $name) = @_; $name ||= "barfoo_ok"; Test::Builder->new->subtest($name => sub { plan tests => 2; ok $value =~ /foo/, "foo"; ok $value =~ /bar/, "bar"; BEGIN{ $line{barfoo_ok_bar} = __LINE__ } }); } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{barfoo_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); barfoo_ok "foot", "namehere"; test_test("barfoo_ok failing line numbers"); } # Wrap barfoo_ok() to make another new predicate... sub barfoo_ok_2 ($;$) { my ($value, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; barfoo_ok($value, $name); } { test_out("# Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{barfoo_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line ".(__LINE__+2)."."); barfoo_ok_2 "foot", "namehere"; test_test("barfoo_ok_2 failing line numbers"); } # A subtest-based predicate called from within a subtest { test_out("# Subtest: outergroup"); test_out(" 1..2"); test_out(" ok 1 - this passes"); test_out(" # Subtest: namehere"); test_out(" 1..2"); test_out(" ok 1 - foo"); test_out(" not ok 2 - bar"); test_err(" # Failed test 'bar'"); test_err(" # at $0 line $line{barfoo_ok_bar}."); test_err(" # Looks like you failed 1 test of 2."); test_out(" not ok 2 - namehere"); test_err(" # Failed test 'namehere'"); test_err(" # at $0 line $line{ipredcall}."); test_err(" # Looks like you failed 1 test of 2."); test_out("not ok 1 - outergroup"); test_err("# Failed test 'outergroup'"); test_err("# at $0 line $line{outercall}."); subtest outergroup => sub { plan tests => 2; ok 1, "this passes"; barfoo_ok_2 "foot", "namehere"; BEGIN{ $line{ipredcall} = __LINE__ } }; BEGIN{ $line{outercall} = __LINE__ } test_test("outergroup with internal barfoo_ok_2 failing line numbers"); } has_plan2.t100644001750001750 54314772042322 21570 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::More; BEGIN { if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) { plan skip_all => "Won't work with t/TEST"; } } use strict; use Test::Builder; plan 'no_plan'; is(Test::Builder->new->has_plan, 'no_plan', 'has no_plan'); no_header.t100644001750001750 45214772042322 21644 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/BuilderBEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Test::Builder; # STDOUT must be unbuffered else our prints might come out after # Test::More's. $| = 1; BEGIN { Test::Builder->new->no_header(1); } use Test::More tests => 1; print "1..1\n"; pass; no_ending.t100644001750001750 55514772042322 21664 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builderuse Test::Builder; # HARNESS-NO-STREAM BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } BEGIN { my $t = Test::Builder->new; $t->no_ending(1); } use Test::More tests => 3; # Normally, Test::More would yell that we ran too few tests, but we # suppressed the ending diagnostics. pass; print "ok 2\n"; print "ok 3\n"; inherit_trace.t100644001750001750 104414772042322 22144 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::Tools::Tiny; use strict; use warnings; use Test2::API qw/context run_subtest intercept/; sub do_it { my $ctx = context(); run_subtest foo => sub { ok(1, "pass"); }, {inherit_trace => 1}; $ctx->release; } do_it(); do_it(); my $events = intercept { do_it(); do_it(); }; for my $st (@$events) { next unless $st->isa('Test2::Event::Subtest'); is($st->trace->nested, 0, "base subtest is not nested"); is($_->trace->nested, 1, "subevent is nested") for @{$st->subevents}; } done_testing; EventFacet.t100644001750001750 104514772042322 21642 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet'; my $CLASS = 'Test2::EventFacet'; my $one = $CLASS->new(details => 'foo'); is($one->details, "foo", "Got details"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); my $two = $one->clone(details => 'bar'); is($one->details, 'foo', "Original details unchanged"); is($two->details, 'bar', "Clone details changed"); ok(!$CLASS->is_list, "Not a list by default"); ok(!$CLASS->facet_key, "No key for base class"); done_testing; Diag.t100644001750001750 246314772042322 21550 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Diag; use Test2::EventFacet::Trace; my $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); is($diag->summary, 'foo', "summary is just message"); $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); is($diag->message, 'undef', "set undef message to undef"); is($diag->summary, 'undef', "summary is just message even when undef"); $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); like($diag->message, qr/^HASH\(.*\)$/, "stringified the input value"); ok($diag->diagnostics, "Diag events are counted as diagnostics"); $diag = Test2::Event::Diag->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => "Hi there", ); my $facet_data = $diag->facet_data; ok($facet_data->{about}, "Got 'about' from common"); ok($facet_data->{trace}, "Got 'trace' from common"); is_deeply( $facet_data->{info}, [{ tag => 'DIAG', debug => 1, details => 'Hi there', }], "Got info facet" ); done_testing; Skip.t100644001750001750 163614772042322 21613 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse Test2::Tools::Tiny; use strict; use warnings; use Test2::Event::Skip; use Test2::EventFacet::Trace; my $skip = Test2::Event::Skip->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), name => 'skip me', reason => 'foo', ); my $facet_data = $skip->facet_data; ok($facet_data->{about}, "Got basic data"); is_deeply( $facet_data->{amnesty}, [ { tag => 'skip', details => 'foo', inherited => 0, } ], "Added some amnesty for the skip", ); is($skip->name, 'skip me', "set name"); is($skip->reason, 'foo', "got skip reason"); ok(!$skip->pass, "no default for pass"); ok($skip->effective_pass, "TODO always effectively passes"); is($skip->summary, "skip me (SKIP: foo)", "summary with reason"); $skip->set_reason(''); is($skip->summary, "skip me (SKIP)", "summary without reason"); done_testing; Fail.t100644001750001750 224014772042322 21550 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept context/; use ok 'Test2::Event::Fail'; my $CLASS = 'Test2::Event::Fail'; my $one = $CLASS->new(name => 'no soup for you'); is($one->summary, "fail", 'summary'); is($one->increments_count, 1, 'increments_count'); is($one->diagnostics, 0, 'diagnostics'); is($one->no_display, 0, 'no_display'); is($one->subtest_id, undef, 'subtest_id'); is($one->terminate, undef, 'terminate'); is($one->global, undef, 'global'); is($one->sets_plan, undef, 'sets_plan'); is($one->causes_fail, 1, 'causes_fail'); $one->add_amnesty({tag => 'blah', details => 'blah'}); is($one->causes_fail, 0, 'causes_fail is off with amnesty'); $one->add_info({tag => 'xxx', details => 'yyy'}); is_deeply( $one->facet_data, { about => {package => $CLASS, details => 'fail', eid => $one->eid}, assert => {pass => 0, details => 'no soup for you'}, amnesty => [{tag => 'blah', details => 'blah'}], info => [{tag => 'xxx', details => 'yyy'}], }, "Got facet data" ); done_testing; Plan.t100644001750001750 1052614772042322 21615 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Plan; use Test2::EventFacet::Trace; my $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 100, ); is($plan->summary, "Plan is 100 assertions", "simple summary"); is_deeply( [$plan->sets_plan], [100, '', undef], "Got plan details"); ok(!$plan->global, "regular plan is not a global event"); is($plan->terminate, undef, "No terminate for normal plan"); $plan->set_max(0); $plan->set_directive('SKIP'); $plan->set_reason('foo'); is($plan->terminate, 0, "Terminate 0 on skip_all"); is($plan->summary, "Plan is 'SKIP', foo", "skip summary"); is_deeply( [$plan->sets_plan], [0, 'SKIP', 'foo'], "Got skip details"); $plan->set_max(0); $plan->set_directive('NO PLAN'); $plan->set_reason(undef); is($plan->summary, "Plan is 'NO PLAN'", "NO PLAN summary"); is_deeply( [$plan->sets_plan], [0, 'NO PLAN', undef], "Got 'NO PLAN' details"); is($plan->terminate, undef, "No terminate for no_plan"); $plan->set_max(100); $plan->set_directive(undef); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'skip_all', ); is($plan->directive, 'SKIP', "Change skip_all to SKIP"); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'no_plan', ); is($plan->directive, 'NO PLAN', "Change no_plan to 'NO PLAN'"); ok(!$plan->global, "NO PLAN is not global"); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'foo', ); }, qr/'foo' is not a valid plan directive/, "Invalid Directive" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, reason => 'foo', ); }, qr/Cannot have a reason without a directive!/, "Reason without directive" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), ); }, qr/No number of tests specified/, "Nothing to do" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 'skip', ); }, qr/Plan test count 'skip' does not appear to be a valid positive integer/, "Max must be an integer" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 100, ); my $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, undef, "no termination defined"); is_deeply( $facet_data->{plan}, {count => 100}, "Set the count" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'NO PLAN', ); $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, undef, "no termination defined"); is_deeply( $facet_data->{plan}, {count => 0, none => 1}, "No plan" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'SKIP', ); $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, 0, "terminate with 0"); is_deeply( $facet_data->{plan}, {count => 0, skip => 1}, "Skip, no reason" ); $plan = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'SKIP', reason => 'because', ); $facet_data = $plan->facet_data; ok($facet_data->{about}, "Got common facet data"); is($facet_data->{control}->{terminate}, 0, "terminate with 0"); is_deeply( $facet_data->{plan}, {count => 0, skip => 1, details => 'because'}, "Skip, no reason" ); done_testing; Note.t100644001750001750 236214772042322 21607 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Note; use Test2::EventFacet::Trace; my $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); is($note->summary, 'foo', "summary is just message"); $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); is($note->message, 'undef', "set undef message to undef"); is($note->summary, 'undef', "summary is just message even when undef"); $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); like($note->message, qr/^HASH\(.*\)$/, "stringified the input value"); $note = Test2::Event::Note->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'Hi there', ); my $facet_data = $note->facet_data; ok($facet_data->{about}, "Got 'about' from common"); ok($facet_data->{trace}, "Got 'trace' from common"); is_deeply( $facet_data->{info}, [{ tag => 'NOTE', debug => 0, details => 'Hi there', }], "Got info facet" ); done_testing; Pass.t100644001750001750 227114772042322 21607 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept context/; use ok 'Test2::Event::Pass'; my $CLASS = 'Test2::Event::Pass'; my $one = $CLASS->new(name => 'soup for you', trace => {frame => ['foo', 'foo.pl', 42]}); is($one->summary, "pass", 'summary'); is($one->increments_count, 1, 'increments_count'); is($one->diagnostics, 0, 'diagnostics'); is($one->no_display, 0, 'no_display'); is($one->subtest_id, undef, 'subtest_id'); is($one->terminate, undef, 'terminate'); is($one->global, undef, 'global'); is($one->sets_plan, undef, 'sets_plan'); is($one->causes_fail, 0, 'causes_fail is false'); $one->add_amnesty({tag => 'blah', details => 'blah'}); $one->add_info({tag => 'xxx', details => 'yyy'}); is_deeply( $one->facet_data, { trace => {frame => ['foo', 'foo.pl', 42]}, about => {package => $CLASS, details => 'pass', eid => $one->eid}, assert => {pass => 1, details => 'soup for you'}, amnesty => [{tag => 'blah', details => 'blah'}], info => [{tag => 'xxx', details => 'yyy'}], }, "Got facet data" ); done_testing; Bail.t100644001750001750 330714772042322 21551 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Bail; use Test2::EventFacet::Trace; my $bail = Test2::Event::Bail->new( trace => Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42]), reason => 'evil', ); ok($bail->causes_fail, "bailout always causes fail."); is($bail->terminate, 255, "Bail will cause the test to exit."); is($bail->global, 1, "Bail is global, everything should bail"); is($bail->summary, "Bail out! evil", "Summary includes reason"); $bail->set_reason(""); is($bail->summary, "Bail out!", "Summary has no reason"); ok($bail->diagnostics, "Bail events are counted as diagnostics"); is_deeply( $bail->facet_data, { about => { package => 'Test2::Event::Bail', eid => $bail->eid, }, control => { global => 1, terminate => 255, details => '', halt => 1 }, trace => { frame => [ 'foo', 'foo.t', '42', ], pid => $$, tid => 0, }, }, "Got facet data", ); $bail->set_reason('uhg'); is_deeply( $bail->facet_data, { about => { package => 'Test2::Event::Bail', eid => $bail->eid, }, control => { global => 1, terminate => 255, details => 'uhg', halt => 1 }, trace => { frame => [ 'foo', 'foo.t', '42', ], pid => $$, tid => 0, }, }, "Got facet data with reason", ); done_testing; Util000755001750001750 014772042322 20206 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesTrace.t100644001750001750 220314772042322 21566 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Utiluse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; like( exception { 'Test2::EventFacet::Trace'->new() }, qr/The 'frame' attribute is required/, "got error" ); my $one = 'Test2::EventFacet::Trace'->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); is($one->package, 'Foo::Bar', "Got package"); is($one->file, 'foo.t', "Got file"); is($one->line, 5, "Got line"); is($one->subname, 'Foo::Bar::foo', "got subname"); is($one->debug, "at foo.t line 5", "got trace"); $one->set_detail("yo momma"); is($one->debug, "yo momma", "got detail for trace"); $one->set_detail(undef); is( exception { $one->throw('I died') }, "I died at foo.t line 5.\n", "got exception" ); is_deeply( warnings { $one->alert('I cried') }, [ "I cried at foo.t line 5.\n" ], "alter() warns" ); my $snap = $one->snapshot; is_deeply($snap, $one, "identical"); ok($snap != $one, "Not the same instance"); done_testing; Tools000755001750001750 014772042322 20371 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesTiny.t100644001750001750 1157714772042322 21674 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Toolsuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/context intercept test2_stack/; ok(__PACKAGE__->can($_), "imported '$_\()'") for qw{ ok is isnt like unlike diag note is_deeply warnings exception plan skip_all done_testing }; ok(1, "'ok' Test"); is("foo", "foo", "'is' test"); is(undef, undef, "'is' undef test"); isnt("foo", "bar", "'isnt' test"); isnt("foo", undef, "'isnt' undef test 1"); isnt(undef, "foo", "'isnt' undef test 2"); like("foo", qr/o/, "'like' test"); unlike("foo", qr/a/, "'unlike' test"); note("Testing Note"); my $str = "abc"; is_deeply( { a => 1, b => 2, c => { ref => \$str, obj => bless({x => 1}, 'XXX'), array => [1, 2, 3]}}, { a => 1, b => 2, c => { ref => \$str, obj => {x => 1}, array => [1, 2, 3]}}, "'is_deeply' test" ); is_deeply( warnings { warn "aaa\n"; warn "bbb\n" }, [ "aaa\n", "bbb\n" ], "Got warnings" ); is_deeply( warnings { 1 }, [], "no warnings" ); is(exception { die "foo\n" }, "foo\n", "got exception"); is(exception { 1 }, undef, "no exception"); my $main_events = intercept { plan 8; ok(0, "'ok' Test"); is("foo", "bar", "'is' test"); isnt("foo", "foo", "'isnt' test"); like("foo", qr/a/, "'like' test"); unlike("foo", qr/o/, "'unlike' test"); is_deeply( { a => 1, b => 2, c => {}}, { a => 1, b => 2, c => []}, "'is_deeply' test" ); }; my $other_events = intercept { diag("Testing Diag"); note("Testing Note"); }; my ($plan, $ok, $is, $isnt, $like, $unlike, $is_deeply) = grep {!$_->isa('Test2::Event::Diag')} @$main_events; my ($diag, $note) = @$other_events; ok($plan->isa('Test2::Event::Plan'), "got plan"); is($plan->max, 8, "planned for 8 oks"); ok($ok->isa('Test2::Event::Fail'), "got 'ok' result"); is($ok->facets->{assert}->pass, 0, "'ok' test failed"); ok($is->isa('Test2::Event::Fail'), "got 'is' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($isnt->isa('Test2::Event::Fail'), "got 'isnt' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($like->isa('Test2::Event::Fail'), "got 'like' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($unlike->isa('Test2::Event::Fail'), "got 'unlike' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($is_deeply->isa('Test2::Event::Fail'), "got 'is_deeply' result"); is($ok->facets->{assert}->pass, 0, "test failed"); ok($diag->isa('Test2::Event::Diag'), "got 'diag' result"); is($diag->message, "Testing Diag", "got diag message"); ok($note->isa('Test2::Event::Note'), "got 'note' result"); is($note->message, "Testing Note", "got note message"); my $events = intercept { skip_all 'because'; ok(0, "should not see me"); die "should not happen"; }; is(@$events, 1, "1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "got plan"); is($events->[0]->directive, 'SKIP', "plan is skip"); is($events->[0]->reason, 'because', "skip reason"); $events = intercept { is(undef, ""); is("", undef); isnt(undef, undef); like(undef, qr//); unlike(undef, qr//); }; @$events = grep {!$_->isa('Test2::Event::Diag')} @$events; is(@$events, 5, "5 events"); ok(!$_->facets->{assert}->pass, "undef test - should not pass") for @$events; sub tool { context() }; my %params; my $ctx = context(level => -1); my $ictx; $events = intercept { %params = @_; $ictx = tool(); $ictx->ok(1, 'pass'); $ictx->ok(0, 'fail'); my $trace = Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__], ); $ictx->hub->finalize($trace, 1); }; @$events = grep {!$_->isa('Test2::Event::Diag')} @$events; is_deeply( \%params, { context => { %$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef }, hub => $ictx->hub, }, "Passed in some useful params" ); ok($ctx != $ictx, "Different context inside intercept"); is(@$events, 3, "got 3 events"); $ctx->release; $ictx->release; # Test that a bail-out in an intercept does not exit. $events = intercept { $ictx = tool(); $ictx->bail("The world ends"); $ictx->ok(0, "Should not see this"); }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Bail'), "got the bail"); $events = intercept { $ictx = tool(); }; $ictx->release; like( exception { intercept { die 'foo' } }, qr/foo/, "Exception was propagated" ); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Pass'), "got a pass"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); done_testing; }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Pass'), "got a pass"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); done_testing; IPC000755001750001750 014772042322 17704 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesDriver.t100644001750001750 257714772042322 21477 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/IPCuse strict; use warnings; use Test2::IPC::Driver::Files; use Test2::Tools::Tiny; use Test2::API qw/context test2_ipc_drivers/; Test2::IPC::Driver::Files->import(); Test2::IPC::Driver::Files->import(); Test2::IPC::Driver::Files->import(); is_deeply( [test2_ipc_drivers()], ['Test2::IPC::Driver::Files'], "Driver not added multiple times" ); for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { my $one = Test2::IPC::Driver->new; like( exception { $one->$meth }, qr/'\Q$one\E' did not define the required method '$meth'/, "Require override of method $meth" ); } SKIP: { last SKIP if "$]" < 5.008; tests abort => sub { my $one = Test2::IPC::Driver->new(no_fatal => 1); my ($err, $out) = ("", ""); { local *STDERR; local *STDOUT; open(STDERR, '>', \$err); open(STDOUT, '>', \$out); $one->abort('foo'); } is($err, "IPC Fatal Error: foo\n", "Got error"); is($out, "Bail out! IPC Fatal Error: foo\n", "got 'bail-out' on stdout"); ($err, $out) = ("", ""); { local *STDERR; local *STDOUT; open(STDERR, '>', \$err); open(STDOUT, '>', \$out); $one->abort_trace('foo'); } like($out, qr/Bail out! IPC Fatal Error: foo/, "got 'bail-out' on stdout"); like($err, qr/IPC Fatal Error: foo/, "Got error"); }; } done_testing; Formatter.t100644001750001750 321514772042322 21711 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept run_subtest test2_stack/; use Test2::Event::Bail; { package Formatter::Subclass; use base 'Test2::Formatter'; use Test2::Util::HashBase qw{f t}; sub init { my $self = shift; $self->{+F} = []; $self->{+T} = []; } sub write { } sub hide_buffered { 1 } sub terminate { my $s = shift; push @{$s->{+T}}, [@_]; } sub finalize { my $s = shift; push @{$s->{+F}}, [@_]; } } { my $f = Formatter::Subclass->new; intercept { my $hub = test2_stack->top; $hub->format($f); is(1, 1, 'test event 1'); is(2, 2, 'test event 2'); is(3, 2, 'test event 3'); done_testing; }; is(scalar @{$f->f}, 1, 'finalize method was called on formatter'); is_deeply( $f->f->[0], [3, 3, 1, 0, 0], 'finalize method received expected arguments' ); ok(!@{$f->t}, 'terminate method was not called on formatter'); } { my $f = Formatter::Subclass->new; intercept { my $hub = test2_stack->top; $hub->format($f); $hub->send(Test2::Event::Bail->new(reason => 'everything is terrible')); done_testing; }; is(scalar @{$f->t}, 1, 'terminate method was called because of bail event'); ok(!@{$f->f}, 'finalize method was not called on formatter'); } { my $f = Formatter::Subclass->new; intercept { my $hub = test2_stack->top; $hub->format($f); $hub->send(Test2::Event::Plan->new(directive => 'skip_all', reason => 'Skipping all the tests')); done_testing; }; is(scalar @{$f->t}, 1, 'terminate method was called because of plan skip_all event'); ok(!@{$f->f}, 'finalize method was not called on formatter'); } done_testing; intercept.t100644001750001750 213514772042322 21743 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept intercept_deep context run_subtest/; sub streamed { my $name = shift; my $code = shift; my $ctx = context(); my $pass = run_subtest("Subtest: $name", $code, {buffered => 0}, @_); $ctx->release; return $pass; } sub buffered { my $name = shift; my $code = shift; my $ctx = context(); my $pass = run_subtest($name, $code, {buffered => 1}, @_); $ctx->release; return $pass; } my $subtest = sub { ok(1, "pass") }; my $buffered_shallow = intercept { buffered 'buffered shallow' => $subtest }; my $streamed_shallow = intercept { streamed 'streamed shallow' => $subtest }; my $buffered_deep = intercept_deep { buffered 'buffered shallow' => $subtest }; my $streamed_deep = intercept_deep { streamed 'streamed shallow' => $subtest }; is(@$buffered_shallow, 1, "Just got the subtest event"); is(@$streamed_shallow, 2, "Got note, and subtest events"); is(@$buffered_deep, 3, "Got ok, plan, and subtest events"); is(@$streamed_deep, 4, "Got note, ok, plan, and subtest events"); done_testing; AsyncSubtest000755001750001750 014772042322 20553 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2Hub.pm100644001750001750 440514772042322 21772 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/AsyncSubtestpackage Test2::AsyncSubtest::Hub; use strict; use warnings; our $VERSION = '1.302210'; use base 'Test2::Hub::Subtest'; use Test2::Util::HashBase qw/ast_ids ast/; use Test2::Util qw/get_tid/; 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; } } sub send { my $self = shift; my ($e) = @_; if (my $ast = $self->ast) { if ($$ != $ast->pid || get_tid != $ast->tid) { if (my $plan = $e->facet_data->{plan}) { unless ($plan->{skip}) { my $trace = $e->facet_data->{trace}; bless($trace, 'Test2::EventFacet::Trace'); $trace->alert("A plan should not be set inside an async-subtest (did you call done_testing()?)"); return; } } } } return $self->SUPER::send($e); } 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 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 Trace.pm100644001750001750 1532314772042322 21730 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Trace; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util qw/get_tid pkg_to_file gen_uid/; use Time::HiRes qw/time/; use Carp qw/confess/; use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid {+FRAME}; $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail}; unless (defined($_[0]->{+PID}) || defined($_[0]->{+TID}) || defined($_[0]->{+CID})) { $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; } } sub snapshot { my ($orig, @override) = @_; bless {%$orig, @override}, __PACKAGE__; } sub signature { my $self = shift; # Signature is only valid if all of these fields are defined, there is no # signature if any is missing. '0' is ok, but '' is not. return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } ( $self->{+CID}, $self->{+PID}, $self->{+TID}, $self->{+FRAME}->[1], $self->{+FRAME}->[2], ); } sub debug { my $self = shift; return $self->{+DETAILS} if $self->{+DETAILS}; my ($pkg, $file, $line) = $self->call; return "at $file line $line"; } sub alert { my $self = shift; my ($msg) = @_; warn $msg . ' ' . $self->debug . ".\n"; } sub throw { my $self = shift; my ($msg) = @_; die $msg . ' ' . $self->debug . ".\n"; } sub call { @{$_[0]->{+FRAME}} } sub full_call { @{$_[0]->{+FULL_CALLER}} } sub package { $_[0]->{+FRAME}->[0] } sub file { $_[0]->{+FRAME}->[1] } sub line { $_[0]->{+FRAME}->[2] } sub subname { $_[0]->{+FRAME}->[3] } sub warning_bits { $_[0]->{+FULL_CALLER} ? $_[0]->{+FULL_CALLER}->[9] : undef } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Trace - Debug information for events =head1 DESCRIPTION The L object, as well as all L types need to have access to information about where they were created. This object represents that information. =head1 SYNOPSIS use Test2::EventFacet::Trace; my $trace = Test2::EventFacet::Trace->new( frame => [$package, $file, $line, $subname], ); =head1 FACET FIELDS =over 4 =item $string = $trace->{details} =item $string = $trace->details() Used as a custom trace message that will be used INSTEAD of C<< at line >> when calling C<< $trace->debug >>. =item $frame = $trace->{frame} =item $frame = $trace->frame() Get the call frame arrayref. [$package, $file, $line, $subname] =item $int = $trace->{pid} =item $int = $trace->pid() The process ID in which the event was generated. =item $int = $trace->{tid} =item $int = $trace->tid() The thread ID in which the event was generated. =item $id = $trace->{cid} =item $id = $trace->cid() The ID of the context that was used to create the event. =item $uuid = $trace->{uuid} =item $uuid = $trace->uuid() The UUID of the context that was used to create the event. (If uuid tagging was enabled) =item ($pkg, $file, $line, $subname) = $trace->call Get the basic call info as a list. =item @caller = $trace->full_call Get the full caller(N) results. =item $warning_bits = $trace->warning_bits Get index 9 from the full caller info. This is the warnings_bits field. The value of this is not portable across perl versions or even processes. However it can be used in the process that generated it to reproduce the warnings settings in a new scope. eval <warning_bits }; ... context's warning settings apply here ... EOT =back =head2 DISCOURAGED HUB RELATED FIELDS These fields were not always set properly by tools. These are B deprecated by the L facets. These fields are not required, and may only reflect the hub that was current when the event was created, which is not necessarily the same as the hub the event was sent through. Some tools did do a good job setting these to the correct hub, but you cannot always rely on that. Use the 'hubs' facet list instead. =over 4 =item $hid = $trace->{hid} =item $hid = $trace->hid() The ID of the hub that was current when the event was created. =item $huuid = $trace->{huuid} =item $huuid = $trace->huuid() The UUID of the hub that was current when the event was created. (If uuid tagging was enabled). =item $int = $trace->{nested} =item $int = $trace->nested() How deeply nested the event is. =item $bool = $trace->{buffered} =item $bool = $trace->buffered() True if the event was buffered and not sent to the formatter independent of a parent (This should never be set when nested is C<0> or C). =back =head1 METHODS B All facet frames are also methods. =over 4 =item $trace->set_detail($msg) =item $msg = $trace->detail Used to get/set a custom trace message that will be used INSTEAD of C<< at line >> when calling C<< $trace->debug >>. C is an alias to the C
facet field for backwards compatibility. =item $str = $trace->debug Typically returns the string C<< at line >>. If C is set then its value will be returned instead. =item $trace->alert($MESSAGE) This issues a warning at the frame (filename and line number where errors should be reported). =item $trace->throw($MESSAGE) This throws an exception at the frame (filename and line number where errors should be reported). =item ($package, $file, $line, $subname) = $trace->call() Get the caller details for the debug-info. This is where errors should be reported. =item $pkg = $trace->package Get the debug-info package. =item $file = $trace->file Get the debug-info filename. =item $line = $trace->line Get the debug-info line number. =item $subname = $trace->subname Get the debug-info subroutine name. =item $sig = trace->signature Get a signature string that identifies this trace. This is used to check if multiple events are related. The signature includes pid, tid, file, line number, and the cid. =back =head1 SOURCE The source code repository for Test2 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 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 About.pm100644001750001750 271114772042322 21721 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::About; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -package -no_display -uuid -eid }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::About - Facet with event details. =head1 DESCRIPTION This facet has information about the event, such as event package. =head1 FIELDS =over 4 =item $string = $about->{details} =item $string = $about->details() Summary about the event. =item $package = $about->{package} =item $package = $about->package() Event package name. =item $bool = $about->{no_display} =item $bool = $about->no_display() True if the event should be skipped by formatters. =item $uuid = $about->{uuid} =item $uuid = $about->uuid() Will be set to a uuid if uuid tagging was enabled. =item $uuid = $about->{eid} =item $uuid = $about->eid() A unique (for the test job) identifier for the event. =back =head1 SOURCE The source code repository for Test2 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 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 Error.pm100644001750001750 341014772042322 21735 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Error; use strict; use warnings; our $VERSION = '1.302210'; sub facet_key { 'errors' } sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -fail }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Error - Facet for errors that need to be shown. =head1 DESCRIPTION This facet is used when an event needs to convey errors. =head1 NOTES This facet has the hash key C<'errors'>, and is a list of facets instead of a single item. =head1 FIELDS =over 4 =item $string = $error->{details} =item $string = $error->details() Explanation of the error, or the error itself (such as an exception). In perl exceptions may be blessed objects, so this field may contain a blessed object. =item $short_string = $error->{tag} =item $short_string = $error->tag() Short tag to categorize the error. This is usually 10 characters or less, formatters may truncate longer tags. =item $bool = $error->{fail} =item $bool = $error->fail() Not all errors are fatal, some are displayed having already been handled. Set this to true if you want the error to cause the test to fail. Without this the error is simply a diagnostics message that has no effect on the overall pass/fail result. =back =head1 SOURCE The source code repository for Test2 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 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 Wildcard.pm100644001750001750 220014772042322 21733 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Wildcard; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 DieOnFail.pm100644001750001750 266014772042322 21656 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Pluginpackage Test2::Plugin::DieOnFail; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Driver000755001750001750 014772042322 17772 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/IPCFiles.pm100644001750001750 3242714772042322 21562 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/IPC/Driverpackage Test2::IPC::Driver::Files; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals}; use Scalar::Util qw/blessed/; use File::Temp(); use Storable(); use File::Spec(); use POSIX(); use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink/; use Test2::Util::Sig qw/try_sig_mask/; use Test2::API qw/test2_ipc_set_pending/; sub is_viable { 1 } sub init { my $self = shift; my $tmpdir = File::Temp::tempdir( $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX", CLEANUP => 0, TMPDIR => 1, ); $self->abort_trace("Could not get a temp dir") unless $tmpdir; $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); print STDERR "\nIPC Temp Dir: $tmpdir\n\n" if $ENV{T2_KEEP_TEMPDIR}; $self->{+EVENT_IDS} = {}; $self->{+READ_IDS} = {}; $self->{+TIMEOUTS} = {}; $self->{+TID} = get_tid(); $self->{+PID} = $$; $self->{+GLOBALS} = {}; return $self; } sub hub_file { my $self = shift; my ($hid) = @_; my $tdir = $self->{+TEMPDIR}; return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid); } sub event_file { my $self = shift; my ($hid, $e) = @_; my $tempdir = $self->{+TEMPDIR}; my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); $self->abort("'$e' is not an event object!") unless $type->isa('Test2::Event'); my $tid = get_tid(); my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1; my @type = split '::', $type; my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type); return File::Spec->catfile($tempdir, $name); } sub add_hub { my $self = shift; my ($hid) = @_; my $hfile = $self->hub_file($hid); $self->abort_trace("File for hub '$hid' already exists") if -e $hfile; open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!"); print $fh "$$\n" . get_tid() . "\n"; close($fh); } sub drop_hub { my $self = shift; my ($hid) = @_; my $tdir = $self->{+TEMPDIR}; my $hfile = $self->hub_file($hid); $self->abort_trace("File for hub '$hid' does not exist") unless -e $hfile; open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!"); my ($pid, $tid) = <$fh>; close($fh); $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$") unless $pid == $$; $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid()) unless get_tid() == $tid; if ($ENV{T2_KEEP_TEMPDIR}) { my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete")); $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok } else { my ($ok, $err) = do_unlink($hfile); $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok } opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); my %bad; for my $file (readdir($dh)) { next if $file =~ m{\.complete$}; next unless $file =~ m{^$hid}; eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file"; } closedir($dh); return unless keys %bad; my $data; my $ok = eval { require JSON::PP; local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } }; my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed; $data = $json->encode(\%bad); 1; }; $ok ||= eval { require Data::Dumper; local $Data::Dumper::Sortkeys = 1; $data = Data::Dumper::Dumper(\%bad); 1; }; $data = "Could not dump data... sorry." unless defined $data; $self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n"); } sub send { my $self = shift; my ($hid, $e, $global) = @_; my $tempdir = $self->{+TEMPDIR}; my $hfile = $self->hub_file($hid); my $dest = $global ? 'GLOBAL' : $hid; $self->abort(<<" EOT") unless $global || -f $hfile; hub '$hid' is not available, failed to send event! There was an attempt to send an event to a hub in a parent process or thread, but that hub appears to be gone. This can happen if you fork, or start a new thread from inside subtest, and the parent finishes the subtest before the child returns. This can also happen if the parent process is done testing before the child finishes. Test2 normally waits automatically in the root process, but will not do so if Test::Builder is loaded for legacy reasons. EOT my $file = $self->event_file($dest, $e); my $ready = File::Spec->canonpath("$file.ready"); if ($global) { my $name = $ready; $name =~ s{^.*(GLOBAL)}{GLOBAL}; $self->{+GLOBALS}->{$hid}->{$name}++; } # Write and rename the file. my ($ren_ok, $ren_err); my ($ok, $err) = try_sig_mask(sub { Storable::store($e, $file); ($ren_ok, $ren_err) = do_rename("$file", $ready); }); if ($ok) { $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok; test2_ipc_set_pending($file); } else { my $src_file = __FILE__; $err =~ s{ at \Q$src_file\E.*$}{}; chomp($err); my $tid = get_tid(); my $trace = $e->trace->debug; my $type = blessed($e); $self->abort(<<" EOT"); ******************************************************************************* There was an error writing an event: Destination: $dest Origin PID: $$ Origin TID: $tid Event Type: $type Event Trace: $trace File Name: $file Ready Name: $ready Error: $err ******************************************************************************* EOT } return 1; } sub driver_abort { my $self = shift; my ($msg) = @_; local ($@, $!, $?, $^E); eval { my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); open(my $fh, '>>', $abort) or die "Could not open abort file: $!"; print $fh $msg, "\n"; close($fh) or die "Could not close abort file: $!"; 1; } or warn $@; } sub cull { my $self = shift; my ($hid) = @_; my $tempdir = $self->{+TEMPDIR}; opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); my $read = $self->{+READ_IDS}; my $timeouts = $self->{+TIMEOUTS}; my @out; for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) { unless ($info->{global}) { my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1; $timeouts->{$info->{file}} ||= time; if ($next != $info->{eid}) { # Wait up to N seconds for missing events next unless 5 < time - $timeouts->{$info->{file}}; $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}."); } $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1; } my $full = $info->{full_path}; my $obj = $self->read_event_file($full); push @out => $obj; # Do not remove global events next if $info->{global}; if ($ENV{T2_KEEP_TEMPDIR}) { my $complete = File::Spec->canonpath("$full.complete"); my ($ok, $err) = do_rename($full, $complete); $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok; } else { my ($ok, $err) = do_unlink("$full"); $self->abort("Could not unlink IPC file '$full': $err") unless $ok; } } closedir($dh); return @out; } sub parse_event_filename { my $self = shift; my ($file) = @_; # The || is to force 0 in false my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, ""); my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, ""); my @parts = split ipc_separator, $file; my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4)); my ($pid, $tid, $eid) = splice(@parts, 0, 3); my $type = join '::' => @parts; return { file => $file, ready => !!$ready, complete => !!$complete, global => $global, type => $type, hid => $hid, pid => $pid, tid => $tid, eid => $eid, }; } sub should_read_event { my $self = shift; my ($hid, $file) = @_; return if substr($file, 0, 1) eq '.'; return if substr($file, 0, 3) eq 'HUB'; CORE::exit(255) if $file eq 'ABORT'; my $parsed = $self->parse_event_filename($file); return if $parsed->{complete}; return unless $parsed->{ready}; return unless $parsed->{global} || $parsed->{hid} eq $hid; return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++; # Untaint the path. my $full = File::Spec->catfile($self->{+TEMPDIR}, $file); ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT}; $parsed->{full_path} = $full; return $parsed; } sub cmp_events { # Globals first return -1 if $a->{global} && !$b->{global}; return 1 if $b->{global} && !$a->{global}; return $a->{pid} <=> $b->{pid} || $a->{tid} <=> $b->{tid} || $a->{eid} <=> $b->{eid}; } sub read_event_file { my $self = shift; my ($file) = @_; my $obj = Storable::retrieve($file); $self->abort("Got an unblessed object: '$obj'") unless blessed($obj); unless ($obj->isa('Test2::Event')) { my $pkg = blessed($obj); my $mod_file = pkg_to_file($pkg); my ($ok, $err) = try { require $mod_file }; $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") unless $ok; $self->abort("'$obj' is not a 'Test2::Event' object") unless $obj->isa('Test2::Event'); } return $obj; } sub waiting { my $self = shift; require Test2::Event::Waiting; $self->send( GLOBAL => Test2::Event::Waiting->new( trace => Test2::EventFacet::Trace->new(frame => [caller()]), ), 'GLOBAL' ); return; } sub DESTROY { my $self = shift; return unless defined $self->pid; return unless defined $self->tid; return unless $$ == $self->pid; return unless get_tid() == $self->tid; my $tempdir = $self->{+TEMPDIR}; my $aborted = 0; my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); if (-e $abort_file) { $aborted = 1; my ($ok, $err) = do_unlink($abort_file); warn $err unless $ok; } opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); while(my $file = readdir($dh)) { next if $file =~ m/^\.+$/; next if $file =~ m/\.complete$/; my $full = File::Spec->catfile($tempdir, $file); my $sep = ipc_separator; if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) { $full =~ m/^(.*)$/; $full = $1; # Untaint it next if $ENV{T2_KEEP_TEMPDIR}; my ($ok, $err) = do_unlink($full); $self->abort("Could not unlink IPC file '$full': $err") unless $ok; next; } $self->abort("Leftover files in the directory ($full)!\n"); } closedir($dh); if ($ENV{T2_KEEP_TEMPDIR}) { print STDERR "# Not removing temp dir: $tempdir\n"; return; } my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); unlink($abort) if -e $abort; rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver::Files - Temp dir + Files concurrency model. =head1 DESCRIPTION This is the default, and fallback concurrency model for L. This sends events between processes and threads using serialized files in a temporary directory. This is not particularly fast, but it works everywhere. =head1 SYNOPSIS use Test2::IPC::Driver::Files; # IPC is now enabled =head1 ENVIRONMENT VARIABLES =over 4 =item T2_KEEP_TEMPDIR=0 When true, the tempdir used by the IPC driver will not be deleted when the test is done. =item T2_TEMPDIR_TEMPLATE='test2-XXXXXX' This can be used to set the template for the IPC temp dir. The template should follow template specifications from L. =back =head1 SEE ALSO See L for methods. =head1 SOURCE The source code repository for Test2 can be found at 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 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 RealFork.pm100644001750001750 270114772042322 21743 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::RealFork; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; 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 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 Formatter.pm100644001750001750 410714772042322 22073 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Builderpackage Test::Builder::Formatter; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } use Test2::Util::HashBase qw/no_header no_diag/; BEGIN { *OUT_STD = Test2::Formatter::TAP->can('OUT_STD'); *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR'); my $todo = OUT_ERR() + 1; *OUT_TODO = sub() { $todo }; } sub init { my $self = shift; $self->SUPER::init(@_); $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; } sub plan_tap { my ($self, $f) = @_; return if $self->{+NO_HEADER}; return $self->SUPER::plan_tap($f); } sub debug_tap { my ($self, $f, $num) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::debug_tap($f, $num); $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } sub info_tap { my ($self, $f) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::info_tap($f); $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } sub redirect { my ($self, $out) = @_; $_->[0] = OUT_TODO for @$out; } sub no_subtest_space { 1 } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test::Builder; # Loads Test::Builder::Formatter for you =head1 SOURCE The source code repository for Test2 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 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 EventMeta.t100644001750001750 130414772042322 22071 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; BailOnFail.t100644001750001750 211014772042322 22005 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Pluginuse 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; no_leaks_no_fork.t100644001750001750 131414772042322 22253 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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; tbt_01basic.t100644001750001750 237214772042322 21716 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl use Test::Builder::Tester tests => 10; use Test::More; ok(1,"This is a basic test"); test_out("ok 1 - tested"); ok(1,"tested"); test_test("captured okay on basic"); test_out("ok 1 - tested"); ok(1,"tested"); test_test("captured okay again without changing number"); ok(1,"test unrelated to Test::Builder::Tester"); test_out("ok 1 - one"); test_out("ok 2 - two"); ok(1,"one"); ok(2,"two"); test_test("multiple tests"); test_out(qr/ok 1 - tested\n/); ok(1,"tested"); test_test("regexp matching"); test_out("not ok 1 - should fail"); test_err("# Failed test ($0 at line 32)"); test_err("# got: 'foo'"); test_err("# expected: 'bar'"); is("foo","bar","should fail"); test_test("testing failing"); test_out("not ok 1"); test_out("not ok 2"); test_fail(+2); test_fail(+1); fail(); fail(); test_test("testing failing on the same line with no name"); test_out("not ok 1 - name"); test_out("not ok 2 - name"); test_fail(+2); test_fail(+1); fail("name"); fail("name"); test_test("testing failing on the same line with the same name"); test_out("not ok 1 - name # TODO Something"); test_out("# Failed (TODO) test ($0 at line 56)"); TODO: { local $TODO = "Something"; fail("name"); } test_test("testing failing with todo"); is_passing.t100644001750001750 434714772042322 22106 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w use strict; use lib 't/lib'; # We're going to need to override exit() later BEGIN { require Test2::Hub; no warnings 'redefine'; *Test2::Hub::terminate = sub { my $status = @_ ? 0 : shift; CORE::exit $status; }; } use Test::More; use Test::Builder; use Test::Builder::NoOutput; { my $tb = Test::Builder::NoOutput->create; ok $tb->is_passing, "a fresh TB object is passing"; $tb->ok(1); ok $tb->is_passing, " still passing after a test"; $tb->ok(0); ok !$tb->is_passing, " not passing after a failing test"; $tb->ok(1); ok !$tb->is_passing, " a passing test doesn't resurrect it"; $tb->done_testing(3); ok !$tb->is_passing, " a successful plan doesn't help either"; } # See if is_passing() notices a plan overrun { my $tb = Test::Builder::NoOutput->create; $tb->plan( tests => 1 ); $tb->ok(1); ok $tb->is_passing, "Passing with a plan"; $tb->ok(1); ok !$tb->is_passing, " passing test, but it overran the plan"; } # is_passing() vs no_plan { my $tb = Test::Builder::NoOutput->create; $tb->plan( "no_plan" ); ok $tb->is_passing, "Passing with no_plan"; $tb->ok(1); ok $tb->is_passing, " still passing after a test"; $tb->ok(1); ok $tb->is_passing, " and another test"; $tb->_ending; ok $tb->is_passing, " and after the ending"; } # is_passing() vs skip_all { my $tb = Test::Builder::NoOutput->create; { no warnings 'redefine'; local *Test2::Hub::terminate = sub { 1 }; $tb->plan( "skip_all" ); } ok $tb->is_passing, "Passing with skip_all"; } # is_passing() vs done_testing(#) { my $tb = Test::Builder::NoOutput->create; $tb->ok(1); $tb->done_testing(2); ok !$tb->is_passing, "All tests passed but done_testing() does not match"; } # is_passing() with no tests run vs done_testing() { my $tb = Test::Builder::NoOutput->create; $tb->done_testing(); ok !$tb->is_passing, "No tests run with done_testing()"; } # is_passing() with no tests run vs done_testing() { my $tb = Test::Builder::NoOutput->create; $tb->ok(1); $tb->done_testing(); ok $tb->is_passing, "All tests passed with done_testing()"; } done_testing(); 10-set_and_dne.t100644001750001750 100014772042322 21775 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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; Context.t100644001750001750 3407314772042322 21702 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/APIuse strict; use warnings; BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 } use Test2::Tools::Tiny; use Test2::API qw{ context intercept test2_stack test2_add_callback_context_acquire test2_add_callback_context_init test2_add_callback_context_release }; my $error = exception { context(); 1 }; my $exception = "context() called, but return value is ignored at " . __FILE__ . ' line ' . (__LINE__ - 1); like($error, qr/^\Q$exception\E/, "Got the exception" ); my $ref; my $frame; sub wrap(&) { my $ctx = context(); my ($pkg, $file, $line, $sub) = caller(0); $frame = [$pkg, $file, $line, $sub]; $_[0]->($ctx); $ref = "$ctx"; $ctx->release; } wrap { my $ctx = shift; ok($ctx->hub, "got hub"); delete $ctx->trace->frame->[4]; is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); }; wrap { my $ctx = shift; ok("$ctx" ne "$ref", "Got a new context"); my $new = context(); my @caller = caller(0); is_deeply( $new, {%$ctx, _is_canon => undef, _is_spawn => [@caller[0,1,2,3]]}, "Additional call to context gets spawn" ); delete $ctx->trace->frame->[4]; is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); $new->release; }; wrap { my $ctx = shift; my $snap = $ctx->snapshot; is_deeply( $snap, {%$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef}, "snapshot is identical except for canon/spawn/aborted" ); ok($ctx != $snap, "snapshot is a new instance"); }; my $end_ctx; { # Simulate an END block... local *END = sub { local *__ANON__ = 'END'; context() }; my $ctx = END(); $frame = [ __PACKAGE__, __FILE__, __LINE__ - 1, 'main::END' ]; # "__LINE__ - 1" on the preceding line forces the value to be an IV # (even though __LINE__ on its own is a PV), just as (caller)[2] is. $end_ctx = $ctx->snapshot; $ctx->release; } delete $end_ctx->trace->frame->[4]; is_deeply( $end_ctx->trace->frame, $frame, 'context is ok in an end block'); # Test event generation { package My::Formatter; sub write { my $self = shift; my ($e) = @_; push @$self => $e; } } my $events = bless [], 'My::Formatter'; my $hub = Test2::Hub->new( formatter => $events, ); my $trace = Test2::EventFacet::Trace->new( frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ], ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $hub, ); my $e = $ctx->build_event('Ok', pass => 1, name => 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); ok(!@$events, "No events yet"); $e = $ctx->send_event('Ok', pass => 1, name => 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->ok(1, 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->note('foo'); is($e->message, 'foo', "got message"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->diag('foo'); is($e->message, 'foo', "got message"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->plan(100); is($e->max, 100, "got max"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->skip('foo', 'because'); is($e->name, 'foo', "got name"); is($e->reason, 'because', "got reason"); ok($e->pass, "skip events pass by default"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->skip('foo', 'because', pass => 0); ok(!$e->pass, "can override skip params"); pop @$events; # Test hooks my @hooks; $hub = test2_stack()->top; my $ref1 = $hub->add_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_init' }); my $ref2 = $hub->add_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_release' }); test2_add_callback_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_init' }); test2_add_callback_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_release' }); my $ref3 = $hub->add_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'hub_acquire' }); test2_add_callback_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'global_acquire' }); sub { push @hooks => 'start'; my $ctx = context(on_init => sub { push @hooks => 'ctx_init' }, on_release => sub { push @hooks => 'ctx_release' }); push @hooks => 'deep'; my $ctx2 = sub { context(on_init => sub { push @hooks => 'ctx_init_deep' }, on_release => sub { push @hooks => 'ctx_release_deep' }); }->(); push @hooks => 'release_deep'; $ctx2->release; push @hooks => 'release_parent'; $ctx->release; push @hooks => 'released_all'; push @hooks => 'new'; $ctx = context(on_init => sub { push @hooks => 'ctx_init2' }, on_release => sub { push @hooks => 'ctx_release2' }); push @hooks => 'release_new'; $ctx->release; push @hooks => 'done'; }->(); $hub->remove_context_init($ref1); $hub->remove_context_release($ref2); $hub->remove_context_acquire($ref3); @{Test2::API::_context_init_callbacks_ref()} = (); @{Test2::API::_context_release_callbacks_ref()} = (); @{Test2::API::_context_acquire_callbacks_ref()} = (); is_deeply( \@hooks, [qw{ start global_acquire hub_acquire global_init hub_init ctx_init deep global_acquire hub_acquire release_deep release_parent ctx_release_deep ctx_release hub_release global_release released_all new global_acquire hub_acquire global_init hub_init ctx_init2 release_new ctx_release2 hub_release global_release done }], "Got all hook in correct order" ); { my $ctx = context(level => -1); my $one = Test2::API::Context->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']), hub => test2_stack()->top, ); is($one->_depth, 0, "default depth"); my $ran = 0; my $doit = sub { is_deeply(\@_, [qw/foo bar/], "got args"); $ran++; die "Make sure old context is restored"; }; eval { $one->do_in_context($doit, 'foo', 'bar') }; my $spawn = context(level => -1, wrapped => -2); is($spawn->trace, $ctx->trace, "Old context restored"); $spawn->release; $ctx->release; ok(!exception { $one->do_in_context(sub {1}) }, "do_in_context works without an original") } { like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace"); my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub"); my $hub = test2_stack()->top; my $ctx = Test2::API::Context->new(trace => $trace, hub => $hub); is($ctx->{_depth}, 0, "depth set to 0 when not defined."); $ctx = Test2::API::Context->new(trace => $trace, hub => $hub, _depth => 1); is($ctx->{_depth}, 1, "Do not reset depth"); like( exception { $ctx->release }, qr/release\(\) should not be called on context that is neither canon nor a child/, "Non canonical context, do not release" ); } sub { like( exception { my $ctx = context(level => 20) }, qr/Could not find context at depth 21/, "Level sanity" ); ok( !exception { my $ctx = context(level => 20, fudge => 1); $ctx->release; }, "Was able to get context when fudging level" ); }->(); sub { my ($ctx1, $ctx2); sub { $ctx1 = context() }->(); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; $ctx2 = context(); $ctx1 = undef; } $ctx2->release; is(@warnings, 1, "1 warning"); like( $warnings[0], qr/^context\(\) was called to retrieve an existing context, however the existing/, "Got expected warning" ); }->(); sub { my $ctx = context(); my $e = exception { $ctx->throw('xxx') }; like($e, qr/xxx/, "got exception"); $ctx = context(); my $warnings = warnings { $ctx->alert('xxx') }; like($warnings->[0], qr/xxx/, "got warning"); $ctx->release; }->(); sub { my $ctx = context; is($ctx->_parse_event('Ok'), 'Test2::Event::Ok', "Got the Ok event class"); is($ctx->_parse_event('+Test2::Event::Ok'), 'Test2::Event::Ok', "Got the +Ok event class"); like( exception { $ctx->_parse_event('+DFASGFSDFGSDGSD') }, qr/Could not load event module 'DFASGFSDFGSDGSD': Can't locate DFASGFSDFGSDGSD\.pm/, "Bad event type" ); }->(); { my ($e1, $e2); my $events = intercept { my $ctx = context(); $e1 = $ctx->ok(0, 'foo', ['xxx']); $e2 = $ctx->ok(0, 'foo'); $ctx->release; }; ok($e1->isa('Test2::Event::Ok'), "returned ok event"); ok($e2->isa('Test2::Event::Ok'), "returned ok event"); is($events->[0], $e1, "got ok event 1"); is($events->[3], $e2, "got ok event 2"); is($events->[2]->message, 'xxx', "event 1 diag 2"); ok($events->[2]->isa('Test2::Event::Diag'), "event 1 diag 2 is diag"); is($events->[3], $e2, "got ok event 2"); } sub { local $! = 100; local $@ = 'foobarbaz'; local $? = 123; my $ctx = context(); is($ctx->errno, 100, "saved errno"); is($ctx->eval_error, 'foobarbaz', "saved eval error"); is($ctx->child_error, 123, "saved child exit"); $! = 22; $@ = 'xyz'; $? = 33; is(0 + $!, 22, "altered \$! in tool"); is($@, 'xyz', "altered \$@ in tool"); is($?, 33, "altered \$? in tool"); sub { my $ctx2 = context(); $! = 42; $@ = 'app'; $? = 43; is(0 + $!, 42, "altered \$! in tool (nested)"); is($@, 'app', "altered \$@ in tool (nested)"); is($?, 43, "altered \$? in tool (nested)"); $ctx2->release; is(0 + $!, 22, "restored the nested \$! in tool"); is($@, 'xyz', "restored the nested \$@ in tool"); is($?, 33, "restored the nested \$? in tool"); }->(); sub { my $ctx2 = context(); $! = 42; $@ = 'app'; $? = 43; is(0 + $!, 42, "altered \$! in tool (nested)"); is($@, 'app', "altered \$@ in tool (nested)"); is($?, 43, "altered \$? in tool (nested)"); # Will not warn since $@ is changed $ctx2 = undef; is(0 + $!, 42, 'Destroy does not reset $!'); is($@, 'app', 'Destroy does not reset $@'); is($?, 43, 'Destroy does not reset $?'); }->(); $ctx->release; is($ctx->errno, 100, "restored errno"); is($ctx->eval_error, 'foobarbaz', "restored eval error"); is($ctx->child_error, 123, "restored child exit"); }->(); sub { local $! = 100; local $@ = 'foobarbaz'; local $? = 123; my $ctx = context(); is($ctx->errno, 100, "saved errno"); is($ctx->eval_error, 'foobarbaz', "saved eval error"); is($ctx->child_error, 123, "saved child exit"); $! = 22; $@ = 'xyz'; $? = 33; is(0 + $!, 22, "altered \$! in tool"); is($@, 'xyz', "altered \$@ in tool"); is($?, 33, "altered \$? in tool"); # Will not warn since $@ is changed $ctx = undef; is(0 + $!, 22, "Destroy does not restore \$!"); is($@, 'xyz', "Destroy does not restore \$@"); is($?, 33, "Destroy does not restore \$?"); }->(); sub { require Test2::EventFacet::Info::Table; my $events = intercept { my $ctx = context(); $ctx->fail('foo', 'bar', Test2::EventFacet::Info::Table->new(rows => [['a', 'b']])); $ctx->fail_and_release('foo', 'bar', Test2::EventFacet::Info::Table->new(rows => [['a', 'b']], as_string => 'a, b')); }; is(@$events, 2, "got 2 events"); is($events->[0]->{info}->[0]->{details}, 'bar', "got first diag"); is($events->[0]->{info}->[1]->{details}, '
', "second diag has default details"); is_deeply( $events->[0]->{info}->[1]->{table}, {rows => [['a', 'b']]}, "Got the table rows" ); is($events->[1]->{info}->[0]->{details}, 'bar', "got first diag"); is($events->[1]->{info}->[1]->{details}, 'a, b', "second diag has custom details"); is_deeply( $events->[1]->{info}->[1]->{table}, {rows => [['a', 'b']]}, "Got the table rows" ); }->(); sub ctx_destroy_test { my (undef, undef, $line1) = caller(); my (@warn, $line2); local $SIG{__WARN__} = sub { push @warn => $_[0] }; { my $ctx = context(); $ctx = undef } $line2 = __LINE__; use Data::Dumper; # print Dumper(@warn); like($warn[0], qr/context appears to have been destroyed without first calling release/, "Is normal context warning"); like($warn[0], qr{\QContext destroyed at ${ \__FILE__ } line $line2\E}, "Reported context destruction trace"); my $created = <<" EOT"; Here are the context creation details, just in case a tool forgot to call release(): File: ${ \__FILE__ } Line: $line1 Tool: main::ctx_destroy_test EOT like($warn[0], qr{\Q$created\E}, "Reported context creation details"); }; ctx_destroy_test(); done_testing; Hub000755001750001750 014772042322 20007 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesSubtest.t100644001750001750 501714772042322 21770 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Hubuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Hub::Subtest; use Test2::Util qw/get_tid/; use Carp qw/croak/; my %TODO; sub def { my ($func, @args) = @_; my @caller = caller(0); $TODO{$caller[0]} ||= []; push @{$TODO{$caller[0]}} => [$func, \@args, \@caller]; } sub do_def { my $for = caller; my $tests = delete $TODO{$for} or croak "No tests to run!"; for my $test (@$tests) { my ($func, $args, $caller) = @$test; my ($pkg, $file, $line) = @$caller; # Note: The '&' below is to bypass the prototype, which is important here. eval <<" EOT" or die $@; package $pkg; # line $line "(eval in DeferredTests) $file" \&$func(\@\$args); 1; EOT } } my $ran = 0; my $event; my $one = Test2::Hub::Subtest->new( nested => 3, ); ok($one->isa('Test2::Hub'), "inheritance"); { no warnings 'redefine'; local *Test2::Hub::process = sub { $ran++; (undef, $event) = @_; 'P!' }; use warnings; my $ok = Test2::Event::Ok->new( pass => 1, name => 'blah', trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($ok), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $ok, "got our event"); def is => ($one->bailed_out, undef, "did not bail"); $ran = 0; $event = undef; my $bail = Test2::Event::Bail->new( message => 'blah', trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($bail), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $bail, "got our event"); } do_def; my $skip = Test2::Event::Plan->new( trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__], pid => $$, tid => get_tid), directive => 'SKIP', reason => 'foo', ); $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->terminate(100, $skip); $ran++; } is($ran, 1, "did not get past the terminate"); $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->send($skip); $ran++; } is($ran, 1, "did not get past the terminate"); $one->reset_state; $one->set_manual_skip_all(1); $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->terminate(100, $skip); $ran++; } is($ran, 2, "did not automatically abort"); $one->reset_state; $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->send($skip); $ran++; } is($ran, 2, "did not automatically abort"); done_testing; init_croak.t100644001750001750 111514772042322 22065 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; BEGIN { package Foo::Bar; use Test2::Util::HashBase qw/foo bar baz/; use Carp qw/croak/; sub init { my $self = shift; croak "'foo' is a required attribute" unless $self->{+FOO}; } } skip_all("known to fail on $]") if "$]" <= 5.006002; $@ = ""; my ($file, $line) = (__FILE__, __LINE__ + 1); eval { my $one = Foo::Bar->new }; my $err = $@; like( $err, qr/^'foo' is a required attribute at \Q$file\E line $line/, "Croak does not report to HashBase from init" ); done_testing; TAP000755001750001750 014772042322 17631 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventVersion.pm100644001750001750 315114772042322 21754 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Event/TAPpackage Test2::Event::TAP::Version; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/version/; sub init { my $self = shift; defined $self->{+VERSION} or croak "'version' is a required attribute"; } sub summary { 'TAP version ' . $_[0]->{+VERSION} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = $self->summary; push @{$out->{info}} => { tag => 'INFO', debug => 0, details => $self->summary, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::TAP::Version - Event for TAP version. =head1 DESCRIPTION This event is used if a TAP formatter wishes to set a version. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Encoding; my $ctx = context(); my $event = $ctx->send_event('TAP::Version', version => 42); =head1 METHODS Inherits from L. Also defines: =over 4 =item $version = $e->version The TAP version being parsed. =back =head1 SOURCE The source code repository for Test2 can be found at 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 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 ExternalMeta.pm100644001750001750 730014772042322 22130 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::ExternalMeta; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/croak/; sub META_KEY() { '_meta' } our @EXPORT = qw/meta set_meta get_meta delete_meta/; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub set_meta { my $self = shift; my ($key, $value) = @_; validate_key($key); $self->{+META_KEY} ||= {}; $self->{+META_KEY}->{$key} = $value; } sub get_meta { my $self = shift; my ($key) = @_; validate_key($key); my $meta = $self->{+META_KEY} or return undef; return $meta->{$key}; } sub delete_meta { my $self = shift; my ($key) = @_; validate_key($key); my $meta = $self->{+META_KEY} or return undef; delete $meta->{$key}; } sub meta { my $self = shift; my ($key, $default) = @_; validate_key($key); my $meta = $self->{+META_KEY}; return undef unless $meta || defined($default); unless($meta) { $meta = {}; $self->{+META_KEY} = $meta; } $meta->{$key} = $default if defined($default) && !defined($meta->{$key}); return $meta->{$key}; } sub validate_key { my $key = shift; return if $key && !ref($key); my $render_key = defined($key) ? "'$key'" : 'undef'; croak "Invalid META key: $render_key, keys must be true, and may not be references"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data to your instances. =head1 DESCRIPTION This package lets you define a clear, and consistent way to allow third party tools to attach meta-data to your instances. If your object consumes this package, and imports its methods, then third party meta-data has a safe place to live. =head1 SYNOPSIS package My::Object; use strict; use warnings; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; ... Now to use it: my $inst = My::Object->new; $inst->set_meta(foo => 'bar'); my $val = $inst->get_meta('foo'); =head1 WHERE IS THE DATA STORED? This package assumes your instances are blessed hashrefs, it will not work if that is not true. It will store all meta-data in the C<_meta> key on your objects hash. If your object makes use of the C<_meta> key in its underlying hash, then there is a conflict and you cannot use this package. =head1 EXPORTS =over 4 =item $val = $obj->meta($key) =item $val = $obj->meta($key, $default) This will get the value for a specified meta C<$key>. Normally this will return C when there is no value for the C<$key>, however you can specify a C<$default> value to set when no value is already set. =item $val = $obj->get_meta($key) This will get the value for a specified meta C<$key>. This does not have the C<$default> overhead that C does. =item $val = $obj->delete_meta($key) This will remove the value of a specified meta C<$key>. The old C<$val> will be returned. =item $obj->set_meta($key, $val) Set the value of a specified meta C<$key>. =back =head1 META-KEY RESTRICTIONS Meta keys must be defined, and must be true when used as a boolean. Keys may not be references. You are free to stringify a reference C<"$ref"> for use as a key, but this package will not stringify it for you. =head1 SOURCE The source code repository for Test2 can be found at 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 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 Render.pm100644001750001750 377414772042322 22100 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Render; use strict; use warnings; our $VERSION = '1.302210'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -facet -mode }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Render - Facet that dictates how to render an event. =head1 DESCRIPTION This facet is used to dictate how the event should be rendered by the standard test2 rendering tools. If this facet is present then ONLY what is specified by it will be rendered. It is assumed that anything important or note-worthy will be present here, no other facets will be considered for rendering/display. This facet is a list type, you can add as many items as needed. =head1 FIELDS =over 4 =item $string = $render->[#]->{details} =item $string = $render->[#]->details() Human readable text for display. =item $string = $render->[#]->{tag} =item $string = $render->[#]->tag() Tag that should prefix/identify the main text. =item $string = $render->[#]->{facet} =item $string = $render->[#]->facet() Optional, if the display text was generated from another facet this should state what facet it was. =item $mode = $render->[#]->{mode} =item $mode = $render->[#]->mode() =over 4 =item calculated Calculated means the facet was generated from another facet. Calculated facets may be cleared and regenerated whenever the event state changes. =item replace Replace means the facet is intended to replace the normal rendering of the event. =back =back =head1 SOURCE The source code repository for Test2 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 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 Assert.pm100644001750001750 325514772042322 22114 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Assert; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -pass -no_debug -number }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Assert - Facet representing an assertion. =head1 DESCRIPTION The assertion facet is provided by any event representing an assertion that was made. =head1 FIELDS =over 4 =item $string = $assert->{details} =item $string = $assert->details() Human readable description of the assertion. =item $bool = $assert->{pass} =item $bool = $assert->pass() True if the assertion passed. =item $bool = $assert->{no_debug} =item $bool = $assert->no_debug() Set this to true if you have provided custom diagnostics and do not want the defaults to be displayed. =item $int = $assert->{number} =item $int = $assert->number() (Optional) assertion number. This may be omitted or ignored. This is usually only useful when parsing/processing TAP. B: This is not set by the Test2 system, assertion number is not known until AFTER the assertion has been processed. This attribute is part of the spec only for harnesses. =back =head1 SOURCE The source code repository for Test2 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 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 Parent.pm100644001750001750 335214772042322 22102 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Parent; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/confess/; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{-hid -children -buffered -start_stamp -stop_stamp}; sub init { confess "Attribute 'hid' must be set" unless defined $_[0]->{+HID}; $_[0]->{+CHILDREN} ||= []; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Parent - Facet for events contains other events =head1 DESCRIPTION This facet is used when an event contains other events, such as a subtest. =head1 FIELDS =over 4 =item $string = $parent->{details} =item $string = $parent->details() Human readable description of the event. =item $hid = $parent->{hid} =item $hid = $parent->hid() Hub ID of the hub that is represented in the parent-child relationship. =item $arrayref = $parent->{children} =item $arrayref = $parent->children() Arrayref containing the facet-data hashes of events nested under this one. I =item $bool = $parent->{buffered} =item $bool = $parent->buffered() True if the subtest is buffered (meaning the formatter has probably not seen them yet). =back =head1 SOURCE The source code repository for Test2 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 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 Negatable.pm100644001750001750 431114772042322 22071 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::Negatable; use strict; use warnings; our $VERSION = '1.302210'; 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 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 EventMeta.pm100644001750001750 316314772042322 22103 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::EventMeta; use strict; use warnings; use base 'Test2::Compare::Meta'; our $VERSION = '1.302210'; 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 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 BailOnFail.pm100644001750001750 271714772042322 22027 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Pluginpackage Test2::Plugin::BailOnFail; use strict; use warnings; our $VERSION = '1.302210'; 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 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 BlockBase.t100644001750001750 15014772042322 22230 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Workflowuse Test2::Bundle::Extended -target => 'Test2::Workflow::BlockBase'; skip_all "Tests not yet written"; AsyncSubtest.t100644001750001750 365114772042322 22351 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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; ExitSummary.t100644001750001750 367614772042322 22356 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Pluginuse 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(); for_do_t.test100644001750001750 16014772042322 22326 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest# Test used by t/subtest/do.t use Test::More; pass("First"); pass("Second"); pass("Third"); done_testing(3); 6_cmp_ok.t100644001750001750 41114772042322 22142 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Regressionuse Test::More; use Test2::API qw/intercept/; my $events = intercept { local $SIG{__WARN__} = sub { 1 }; my $foo = undef; cmp_ok($foo, "ne", ""); }; is($events->[-1]->message, < 16; use Test::Builder; my $Test = Test::Builder->new; my $r = $Test->maybe_regex(qr/^FOO$/i); ok(defined $r, 'qr// detected'); ok(('foo' =~ /$r/), 'qr// good match'); ok(('bar' !~ /$r/), 'qr// bad match'); SKIP: { skip "blessed regex checker added in 5.10", 3 if $] < 5.010; my $obj = bless qr/foo/, 'Wibble'; my $re = $Test->maybe_regex($obj); ok( defined $re, "blessed regex detected" ); ok( ('foo' =~ /$re/), 'blessed qr/foo/ good match' ); ok( ('bar' !~ /$re/), 'blessed qr/foo/ bad math' ); } { my $r = $Test->maybe_regex('/^BAR$/i'); ok(defined $r, '"//" detected'); ok(('bar' =~ m/$r/), '"//" good match'); ok(('foo' !~ m/$r/), '"//" bad match'); }; { my $r = $Test->maybe_regex('not a regex'); ok(!defined $r, 'non-regex detected'); }; { my $r = $Test->maybe_regex('/0/'); ok(defined $r, 'non-regex detected'); ok(('f00' =~ m/$r/), '"//" good match'); ok(('b4r' !~ m/$r/), '"//" bad match'); }; { my $r = $Test->maybe_regex('m,foo,i'); ok(defined $r, 'm,, detected'); ok(('fOO' =~ m/$r/), '"//" good match'); ok(('bar' !~ m/$r/), '"//" bad match'); }; 43-bag-on-empty.t100644001750001750 56514772042322 22036 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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; todo_and_facets.t100644001750001750 175014772042322 22444 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Test2::API qw/context/; use Test2::Tools::Basic qw/todo done_testing/; use Test::More(); BEGIN { *tm_ok = \&Test::More::ok; *tm_pass = \&Test::More::pass; *tm_fail = \&Test::More::fail; *bas_ok = \&Test2::Tools::Basic::ok; } 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 our $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; 662-tbt-no-plan.t100644001750001750 106414772042322 21774 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test::Builder::Tester; use Test::More tests => 1; use strict; use warnings; BEGIN { package Example::Tester; use base 'Test::Builder::Module'; $INC{'Example/Tester.pm'} = 1; sub import { my $package = shift; my %args = @_; my $callerpack = caller; my $tb = __PACKAGE__->builder; $tb->exported_to($callerpack); local $SIG{__WARN__} = sub { }; $tb->no_plan; } } test_out('ok 1 - use Example::Tester;'); use_ok('Example::Tester'); test_test("use Example::Tester;"); Breakage.t100644001750001750 604714772042322 21737 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/APIuse strict; use warnings; if ("$]" < 5.008) { print "1..0 # SKIP Test cannot run on perls below 5.8.0 because local doesn't work on hash keys.\n"; exit 0; } use Test2::IPC; use Test2::Tools::Tiny; use Test2::API::Breakage; my $CLASS = 'Test2::API::Breakage'; for my $meth (qw/upgrade_suggested upgrade_required known_broken/) { my @list = $CLASS->$meth; ok(!(@list % 2), "Got even list ($meth)"); ok(!(grep {!defined($_)} @list), "No undefined items ($meth)"); } { no warnings 'redefine'; local *Test2::API::Breakage::upgrade_suggested = sub { return ('T2Test::UG1' => '1.0', 'T2Test::UG2' => '0.5'); }; local *Test2::API::Breakage::upgrade_required = sub { return ('T2Test::UR1' => '1.0', 'T2Test::UR2' => '0.5'); }; local *Test2::API::Breakage::known_broken = sub { return ('T2Test::KB1' => '1.0', 'T2Test::KB2' => '0.5'); }; use warnings 'redefine'; ok(!$CLASS->report, "Nothing to report"); ok(!$CLASS->report(1), "Still nothing to report"); { local $INC{"T2Test/UG1.pm"} = "T2Test/UG1.pm"; local $INC{"T2Test/UG2.pm"} = "T2Test/UG2.pm"; local $INC{"T2Test/UR1.pm"} = "T2Test/UR1.pm"; local $INC{"T2Test/UR2.pm"} = "T2Test/UR2.pm"; local $INC{"T2Test/KB1.pm"} = "T2Test/KB1.pm"; local $INC{"T2Test/KB2.pm"} = "T2Test/KB2.pm"; local $T2Test::UG1::VERSION = '0.9'; local $T2Test::UG2::VERSION = '0.9'; local $T2Test::UR1::VERSION = '0.9'; local $T2Test::UR2::VERSION = '0.9'; local $T2Test::KB1::VERSION = '0.9'; local $T2Test::KB2::VERSION = '0.9'; my @report = $CLASS->report; $_ =~ s{\S+/Breakage\.pm}{Breakage.pm}g for @report; is_deeply( [sort @report], [ sort " * Module 'T2Test::UR1' is outdated and known to be broken, please update to 1.0 or higher.", " * Module 'T2Test::KB1' is known to be broken in version 1.0 and below, newer versions have not been tested. You have: 0.9", " * Module 'T2Test::KB2' is known to be broken in version 0.5 and below, newer versions have not been tested. You have: 0.9", " * Module 'T2Test::UG1' is outdated, we recommend updating above 1.0. error was: 'T2Test::UG1 version 1.0 required--this is only version 0.9 at Breakage.pm line 75.'; INC is T2Test/UG1.pm", ], "Got expected report items" ); } my %look; unshift @INC => sub { my ($this, $file) = @_; $look{$file}++ if $file =~ m{T2Test}; return; }; ok(!$CLASS->report, "Nothing to report"); is_deeply(\%look, {}, "Did not try to load anything"); ok(!$CLASS->report(1), "Nothing to report"); is_deeply( \%look, { 'T2Test/UG1.pm' => 1, 'T2Test/UG2.pm' => 1, 'T2Test/UR1.pm' => 1, 'T2Test/UR2.pm' => 1, 'T2Test/KB1.pm' => 1, 'T2Test/KB2.pm' => 1, }, "Tried to load modules" ); } done_testing; Instance.t100644001750001750 3515714772042322 22026 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/APIuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/; ok(1, "Just to get things initialized."); # We need to control these env vars for this test $ENV{T2_NO_IPC} = 0; $ENV{T2_TRACE_STAMPS} = 0; # This test relies on TAP being the default formatter for non-canon instances $ENV{T2_FORMATTER} = 'TAP'; my $CLASS = 'Test2::API::Instance'; my $one = $CLASS->new; is_deeply( $one, { contexts => {}, finalized => undef, ipc => undef, formatter => undef, add_uuid_via => undef, ipc_polling => undef, ipc_drivers => [], ipc_timeout => 30, ipc_disabled => 0, formatters => [], no_wait => 0, loaded => 0, exit_callbacks => [], post_load_callbacks => [], context_acquire_callbacks => [], context_init_callbacks => [], context_release_callbacks => [], pre_subtest_callbacks => [], trace_stamps => 0, stack => [], }, "Got initial settings" ); %$one = (); is_deeply($one, {}, "wiped object"); $one->reset; is_deeply( $one, { contexts => {}, ipc_polling => undef, ipc_drivers => [], ipc_timeout => 30, ipc_disabled => 0, add_uuid_via => undef, formatters => [], finalized => undef, ipc => undef, formatter => undef, no_wait => 0, loaded => 0, exit_callbacks => [], post_load_callbacks => [], context_acquire_callbacks => [], context_init_callbacks => [], context_release_callbacks => [], pre_subtest_callbacks => [], trace_stamps => 0, stack => [], }, "Reset Object" ); ok(!$one->formatter_set, "no formatter set"); $one->set_formatter('Foo'); ok($one->formatter_set, "formatter set"); $one->reset; my $ran = 0; my $callback = sub { $ran++ }; $one->add_post_load_callback($callback); ok(!$ran, "did not run yet"); is_deeply($one->post_load_callbacks, [$callback], "stored callback for later"); ok(!$one->loaded, "not loaded"); $one->load; ok($one->loaded, "loaded"); is($ran, 1, "ran the callback"); $one->load; is($ran, 1, "Did not run the callback again"); $one->add_post_load_callback($callback); is($ran, 2, "ran the new callback"); is_deeply($one->post_load_callbacks, [$callback, $callback], "stored callback for the record"); like( exception { $one->add_post_load_callback({}) }, qr/Post-load callbacks must be coderefs/, "Post-load callbacks must be coderefs" ); $one->reset; ok($one->ipc, 'got ipc'); ok($one->finalized, "calling ipc finalized the object"); $one->reset; ok($one->stack, 'got stack'); ok(!$one->finalized, "calling stack did not finaliz the object"); $one->reset; ok($one->formatter, 'Got formatter'); ok($one->finalized, "calling format finalized the object"); $one->reset; $one->set_formatter('Foo'); is($one->formatter, 'Foo', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); { local $ENV{T2_FORMATTER} = 'TAP'; my $one = $CLASS->new; is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); local $ENV{T2_FORMATTER} = '+Test2::Formatter::TAP'; $one->reset; is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); local $ENV{T2_FORMATTER} = '+A::Fake::Module::That::Should::Not::Exist'; $one->reset; like( exception { $one->formatter }, qr/COULD NOT LOAD FORMATTER 'A::Fake::Module::That::Should::Not::Exist' \(set by the 'T2_FORMATTER' environment variable\)/, "Bad formatter" ); } $ran = 0; $one->reset; $one->add_exit_callback($callback); is(@{$one->exit_callbacks}, 1, "added an exit callback"); $one->add_exit_callback($callback); is(@{$one->exit_callbacks}, 2, "added another exit callback"); like( exception { $one->add_exit_callback({}) }, qr/End callbacks must be coderefs/, "Exit callbacks must be coderefs" ); $one->reset; $one->add_pre_subtest_callback($callback); is(@{$one->pre_subtest_callbacks}, 1, "added a pre-subtest callback"); $one->add_pre_subtest_callback($callback); is(@{$one->pre_subtest_callbacks}, 2, "added another pre-subtest callback"); like( exception { $one->add_pre_subtest_callback({}) }, qr/Pre-subtest callbacks must be coderefs/, "Pre-subtest callbacks must be coderefs" ); if (CAN_REALLY_FORK) { my $one = $CLASS->new; my $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { exit 0 } is(Test2::API::Instance::_ipc_wait, 0, "No errors"); $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { exit 255 } my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly"); } like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 255, sig: 0\)/, "Warn about exit"); $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { sleep 20; exit 0 } kill('TERM', $pid) or die "Failed to send signal"; @warnings = (); { local $SIG{__WARN__} = sub { push @warnings => @_ }; is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly"); } like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 0, sig: 15\)/, "Warn about exit"); } if (CAN_THREAD && "$]" >= 5.010) { require threads; my $one = $CLASS->new; threads->new(sub { 1 }); is(Test2::API::Instance::_ipc_wait, 0, "No errors"); if (threads->can('error')) { threads->new(sub { close(STDERR); close(STDOUT); die "xxx" }); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; is(Test2::API::Instance::_ipc_wait, 255, "Thread exited badly"); } like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit"); } } { my $one = $CLASS->new; local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { my $one = $CLASS->new; $one->set__tid(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { my $one = $CLASS->new; $one->stack->top; $one->set_no_wait(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { my $one = $CLASS->new; $one->stack->top->set_no_ending(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { my $one = $CLASS->new; $one->load(); $one->stack->top->set_failed(2); local $? = 0; $one->set_exit; is($?, 2, "number of failures"); } { my $one = $CLASS->new; $one->load(); local $? = 500; $one->set_exit; is($?, 255, "set exit code to a sane number"); } { local %INC = %INC; delete $INC{'Test2/IPC.pm'}; my $one = $CLASS->new; $one->load(); my @events; $one->stack->top->filter(sub { push @events => $_[1]; undef}); $one->stack->new_hub; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); } SKIP: { last SKIP if "$]" < 5.008; my $one = $CLASS->new; my $stderr = ""; { local $INC{'Test/Builder.pm'} = __FILE__; local $Test2::API::VERSION = '0.002'; local $Test::Builder::VERSION = '0.001'; local *STDERR; open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; $one->set_exit; } is($stderr, <<' EOT', "Got warning about version mismatch"); ******************************************************************************** * * * Test::Builder -- Test2::API version mismatch detected * * * ******************************************************************************** Test2::API Version: 0.002 Test::Builder Version: 0.001 This is not a supported configuration, you will have problems. EOT } SKIP: { last SKIP if "$]" < 5.008; require Test2::API::Breakage; no warnings qw/redefine once/; my $ran = 0; local *Test2::API::Breakage::report = sub { $ran++; return "foo" }; use warnings qw/redefine once/; my $one = $CLASS->new; $one->load(); my $stderr = ""; { local *STDERR; open(STDERR, '>', \$stderr) or print "Failed to open new STDERR"; local $? = 255; $one->set_exit; } is($stderr, <<" EOT", "Reported bad modules"); You have loaded versions of test modules known to have problems with Test2. This could explain some test failures. foo EOT } { my $one = $CLASS->new; $one->load(); my @events; $one->stack->top->filter(sub { push @events => $_[1]; undef}); $one->stack->new_hub; ok($one->stack->top->ipc, "Have IPC"); $one->stack->new_hub; ok($one->stack->top->ipc, "Have IPC"); $one->stack->top->set_ipc(undef); ok(!$one->stack->top->ipc, "no IPC"); $one->stack->new_hub; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); } if (CAN_REALLY_FORK) { local $SIG{__WARN__} = sub { }; my $one = $CLASS->new; my $pid = fork; die "Failed to fork!" unless defined $pid; unless ($pid) { exit 255 } $one->_finalize; $one->stack->top; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); $one->reset(); $pid = fork; die "Failed to fork!" unless defined $pid; unless ($pid) { exit 255 } $one->_finalize; $one->stack->top; local $? = 122; $one->set_exit; is($?, 122, "kept original exit"); } { my $one = $CLASS->new; my $ctx = bless { trace => Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']), hub => Test2::Hub->new(), }, 'Test2::API::Context'; $one->contexts->{1234} = $ctx; local $? = 500; my $warnings = warnings { $one->set_exit }; is($?, 255, "set exit code to a sane number"); is_deeply( $warnings, [ "context object was never released! This means a testing tool is behaving very badly at Foo/Bar.pm line 42.\n" ], "Warned about unfreed context" ); $one->set_no_wait(0); } { local %INC = %INC; delete $INC{'Test2/IPC.pm'}; delete $INC{'threads.pm'}; ok(!USE_THREADS, "Sanity Check"); my $one = $CLASS->new; ok(!$one->ipc, 'IPC not loaded, no IPC object'); ok($one->finalized, "calling ipc finalized the object"); is($one->ipc_polling, undef, "no polling defined"); ok(!@{$one->ipc_drivers}, "no driver"); if (CAN_THREAD) { local $INC{'threads.pm'} = 1; no warnings 'once'; local *threads::tid = sub { 0 } unless threads->can('tid'); $one->reset; ok($one->ipc, 'IPC loaded if threads are'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); } { local $INC{'Test2/IPC.pm'} = 1; $one->reset; ok($one->ipc, 'IPC loaded if Test2::IPC is'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); } require Test2::IPC::Driver::Files; $one->reset; $one->add_ipc_driver('Test2::IPC::Driver::Files'); ok($one->ipc, 'IPC loaded if drivers have been added'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); my $file = __FILE__; my $line = __LINE__ + 1; my $warnings = warnings { $one->add_ipc_driver('Test2::IPC::Driver::Files') }; like( $warnings->[0], qr{^IPC driver Test2::IPC::Driver::Files loaded too late to be used as the global ipc driver at \Q$file\E line $line}, "Got warning at correct frame" ); $one->reset; $one->add_ipc_driver('Fake::Fake::XXX'); is( exception { $one->ipc }, "IPC has been requested, but no viable drivers were found. Aborting...\n", "Failed without viable IPC driver" ); } { my $one = $CLASS->new; $one->{ipc} = Test2::IPC::Driver::Files->new; ok(!@{$one->context_init_callbacks}, "no callbacks"); is($one->ipc_polling, undef, "no polling, undef"); $one->disable_ipc_polling; ok(!@{$one->context_init_callbacks}, "no callbacks"); is($one->ipc_polling, undef, "no polling, still undef"); my $cull = 0; no warnings 'once'; local *Fake::Hub::cull = sub { $cull++ }; use warnings; $one->enable_ipc_polling; ok(defined($one->{_pid}), "pid is defined"); ok(defined($one->{_tid}), "tid is defined"); is(@{$one->context_init_callbacks}, 1, "added the callback"); is($one->ipc_polling, 1, "polling on"); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 1, "called cull once"); $cull = 0; $one->disable_ipc_polling; is(@{$one->context_init_callbacks}, 1, "kept the callback"); is($one->ipc_polling, 0, "no polling, set to 0"); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 0, "did not call cull"); $cull = 0; $one->enable_ipc_polling; is(@{$one->context_init_callbacks}, 1, "did not add the callback"); is($one->ipc_polling, 1, "polling on"); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 1, "called cull once"); } { require Test2::IPC::Driver::Files; local $ENV{T2_NO_IPC} = 1; my $one = $CLASS->new; $one->add_ipc_driver('Test2::IPC::Driver::Files'); ok($one->ipc_disabled, "IPC is disabled by env var"); ok(!$one->ipc, 'IPC not loaded'); local $ENV{T2_NO_IPC} = 0; $one->reset; ok(!$one->ipc_disabled, "IPC is not disabled by env var"); ok($one->ipc, 'IPC loaded'); like( exception { $one->ipc_disable }, qr/Attempt to disable IPC after it has been initialized/, "Cannot disable IPC once it is initialized" ); $one->reset; ok(!$one->ipc_disabled, "IPC is not disabled by env var"); $one->ipc_disable; ok($one->ipc_disabled, "IPC is disabled directly"); } Test2::API::test2_ipc_wait_enable(); done_testing; no_load_api.t100644001750001750 303114772042322 22206 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Data::Dumper; # HARNESS-NO-STREAM # HARNESS-NO-PRELOAD ############################################################################### # # # This test is to insure certain objects do not load Test2::API directly or # # indirectly when being required. It is ok for import() to load Test2::API if # # necessary, but simply requiring the modules should not. # # # ############################################################################### require Test2::Formatter; require Test2::Formatter::TAP; require Test2::Event; require Test2::Event::Bail; require Test2::Event::Diag; require Test2::Event::Exception; require Test2::Event::Note; require Test2::Event::Ok; require Test2::Event::Plan; require Test2::Event::Skip; require Test2::Event::Subtest; require Test2::Event::Waiting; require Test2::Util; require Test2::Util::ExternalMeta; require Test2::Util::HashBase; require Test2::EventFacet::Trace; require Test2::Hub; require Test2::Hub::Interceptor; require Test2::Hub::Subtest; require Test2::Hub::Interceptor::Terminator; my @loaded = grep { $INC{$_} } qw{ Test2/API.pm Test2/API/Instance.pm Test2/API/Context.pm Test2/API/Stack.pm }; require Test2::Tools::Tiny; Test2::Tools::Tiny::ok(!@loaded, "Test2::API was not loaded") || Test2::Tools::Tiny::diag("Loaded: " . Dumper(\@loaded)); Test2::Tools::Tiny::done_testing(); Builder000755001750001750 014772042322 17673 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/TestNoOutput.pm100644001750001750 471714772042322 22177 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Builderpackage Test::Builder::NoOutput; use strict; use warnings; use Symbol qw(gensym); use base qw(Test::Builder); =head1 NAME Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing =head1 SYNOPSIS use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->new; ...test as normal... my $output = $tb->read; =head1 DESCRIPTION This is a subclass of Test::Builder which traps all its output. It is mostly useful for testing Test::Builder. =head3 read my $all_output = $tb->read; my $output = $tb->read($stream); Returns all the output (including failure and todo output) collected so far. It is destructive, each call to read clears the output buffer. If $stream is given it will return just the output from that stream. $stream's are... out output() err failure_output() todo todo_output() all all outputs Defaults to 'all'. =cut my $Test = __PACKAGE__->new; sub create { my $class = shift; my $self = $class->SUPER::create(@_); require Test::Builder::Formatter; $self->{Stack}->top->format(Test::Builder::Formatter->new); my %outputs = ( all => '', out => '', err => '', todo => '', ); $self->{_outputs} = \%outputs; my($out, $err, $todo) = map { gensym() } 1..3; tie *$out, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{out}; tie *$err, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{err}; tie *$todo, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{todo}; $self->output($out); $self->failure_output($err); $self->todo_output($todo); return $self; } sub read { my $self = shift; my $stream = @_ ? shift : 'all'; my $out = $self->{_outputs}{$stream}; $self->{_outputs}{$stream} = ''; # Clear all the streams if 'all' is read. if( $stream eq 'all' ) { my @keys = keys %{$self->{_outputs}}; $self->{_outputs}{$_} = '' for @keys; } return $out; } package Test::Builder::NoOutput::Tee; # A cheap implementation of IO::Tee. sub TIEHANDLE { my($class, @refs) = @_; my @fhs; for my $ref (@refs) { my $fh = Test::Builder->_new_fh($ref); push @fhs, $fh; } my $self = [@fhs]; return bless $self, $class; } sub PRINT { my $self = shift; print $_ @_ for @$self; } sub PRINTF { my $self = shift; my $format = shift; printf $_ @_ for @$self; } 1; BlockBase.pm100644001750001750 612014772042322 22260 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Workflowpackage Test2::Workflow::BlockBase; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Facets2Legacy.pm100644001750001750 1542714772042322 22204 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Utilpackage Test2::Util::Facets2Legacy; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/croak confess/; use Scalar::Util qw/blessed/; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT_OK = qw{ causes_fail diagnostics global increments_count no_display sets_plan subtest_id summary terminate uuid }; our %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); our $CYCLE_DETECT = 0; sub _get_facet_data { my $in = shift; if (blessed($in) && $in->isa('Test2::Event')) { confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)" if $CYCLE_DETECT; local $CYCLE_DETECT = 1; return $in->facet_data; } return $in if ref($in) eq 'HASH'; croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref"; } sub causes_fail { my $facet_data = _get_facet_data(shift @_); return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}}; if (my $control = $facet_data->{control}) { return 1 if $control->{halt}; return 1 if $control->{terminate}; } return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}}; return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass}; return 0; } sub diagnostics { my $facet_data = _get_facet_data(shift @_); return 1 if $facet_data->{errors} && @{$facet_data->{errors}}; return 0 unless $facet_data->{info} && @{$facet_data->{info}}; return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0; } sub global { my $facet_data = _get_facet_data(shift @_); return 0 unless $facet_data->{control}; return $facet_data->{control}->{global}; } sub increments_count { my $facet_data = _get_facet_data(shift @_); return $facet_data->{assert} ? 1 : 0; } sub no_display { my $facet_data = _get_facet_data(shift @_); return 0 unless $facet_data->{about}; return $facet_data->{about}->{no_display}; } sub sets_plan { my $facet_data = _get_facet_data(shift @_); my $plan = $facet_data->{plan} or return; my @out = ($plan->{count} || 0); if ($plan->{skip}) { push @out => 'SKIP'; push @out => $plan->{details} if defined $plan->{details}; } elsif ($plan->{none}) { push @out => 'NO PLAN' } return @out; } sub subtest_id { my $facet_data = _get_facet_data(shift @_); return undef unless $facet_data->{parent}; return $facet_data->{parent}->{hid}; } sub summary { my $facet_data = _get_facet_data(shift @_); return '' unless $facet_data->{about} && $facet_data->{about}->{details}; return $facet_data->{about}->{details}; } sub terminate { my $facet_data = _get_facet_data(shift @_); return undef unless $facet_data->{control}; return $facet_data->{control}->{terminate}; } sub uuid { my $in = shift; if ($CYCLE_DETECT) { if (blessed($in) && $in->isa('Test2::Event')) { my $meth = $in->can('uuid'); $meth = $in->can('SUPER::uuid') if $meth == \&uuid; my $uuid = $in->$meth if $meth && $meth != \&uuid; return $uuid if $uuid; } return undef; } my $facet_data = _get_facet_data($in); return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid}; return undef; } 1; =pod =encoding UTF-8 =head1 NAME Test2::Util::Facets2Legacy - Convert facet data to the legacy event API. =head1 DESCRIPTION This module exports several subroutines from the older event API (see L). These subroutines can be used as methods on any object that provides a custom C method. These subroutines can also be used as functions that take a facet data hashref as arguments. =head1 SYNOPSIS =head2 AS METHODS package My::Event; use Test2::Util::Facets2Legacy ':ALL'; sub facet_data { return { ... } } Then to use it: my $e = My::Event->new(...); my $causes_fail = $e->causes_fail; my $summary = $e->summary; .... =head2 AS FUNCTIONS use Test2::Util::Facets2Legacy ':ALL'; my $f = { assert => { ... }, info => [{...}, ...], control => {...}, ... }; my $causes_fail = causes_fail($f); my $summary = summary($f); =head1 NOTE ON CYCLES When used as methods, all these subroutines call C<< $e->facet_data() >>. The default C method in L relies on the legacy methods this module emulates in order to work. As a result of this it is very easy to create infinite recursion bugs. These methods have cycle detection and will throw an exception early if a cycle is detected. C is currently the only subroutine in this library that has a fallback behavior when cycles are detected. =head1 EXPORTS Nothing is exported by default. You must specify which methods to import, or use the ':ALL' tag. =over 4 =item $bool = $e->causes_fail() =item $bool = causes_fail($f) Check if the event or facets result in a failing state. =item $bool = $e->diagnostics() =item $bool = diagnostics($f) Check if the event or facets contain any diagnostics information. =item $bool = $e->global() =item $bool = global($f) Check if the event or facets need to be globally processed. =item $bool = $e->increments_count() =item $bool = increments_count($f) Check if the event or facets make an assertion. =item $bool = $e->no_display() =item $bool = no_display($f) Check if the event or facets should be rendered or hidden. =item ($max, $directive, $reason) = $e->sets_plan() =item ($max, $directive, $reason) = sets_plan($f) Check if the event or facets set a plan, and return the plan details. =item $id = $e->subtest_id() =item $id = subtest_id($f) Get the subtest id, if any. =item $string = $e->summary() =item $string = summary($f) Get the summary of the event or facets hash, if any. =item $undef_or_int = $e->terminate() =item $undef_or_int = terminate($f) Check if the event or facets should result in process termination, if so the exit code is returned (which could be 0). undef is returned if no termination is requested. =item $uuid = $e->uuid() =item $uuid = uuid($f) Get the UUID of the facets or event. B This will fall back to C<< $e->SUPER::uuid() >> if a cycle is detected and an event is used as the argument. =back =head1 SOURCE The source code repository for Test2 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 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 Control.pm100644001750001750 372514772042322 22275 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Control; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Control - Facet for hub actions and behaviors. =head1 DESCRIPTION This facet is used when the event needs to give instructions to the Test2 internals. =head1 FIELDS =over 4 =item $string = $control->{details} =item $string = $control->details() Human readable explanation for the special behavior. =item $bool = $control->{global} =item $bool = $control->global() True if the event is global in nature and should be seen by all hubs. =item $exit = $control->{terminate} =item $exit = $control->terminate() Defined if the test should immediately exit, the value is the exit code and may be C<0>. =item $bool = $control->{halt} =item $bool = $control->halt() True if all testing should be halted immediately. =item $bool = $control->{has_callback} =item $bool = $control->has_callback() True if the C method on the event should be called. =item $encoding = $control->{encoding} =item $encoding = $control->encoding() This can be used to change the encoding from this event onward. =item $phase = $control->{phase} =item $phase = $control->phase() Used to signal that a phase change has occurred. Currently only the perl END phase is signaled. =back =head1 SOURCE The source code repository for Test2 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 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 Amnesty.pm100644001750001750 315014772042322 22265 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetpackage Test2::EventFacet::Amnesty; use strict; use warnings; our $VERSION = '1.302210'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -inherited }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Amnesty - Facet for assertion amnesty. =head1 DESCRIPTION This package represents what is expected in units of amnesty. =head1 NOTES This facet appears in a list instead of being a single item. =head1 FIELDS =over 4 =item $string = $amnesty->{details} =item $string = $amnesty->details() Human readable explanation of why amnesty was granted. Example: I =item $short_string = $amnesty->{tag} =item $short_string = $amnesty->tag() Short string (usually 10 characters or less, not enforced, but may be truncated by renderers) categorizing the amnesty. =item $bool = $amnesty->{inherited} =item $bool = $amnesty->inherited() This will be true if the amnesty was granted to a parent event and inherited by this event, which is a child, such as an assertion within a subtest that is marked todo. =back =head1 SOURCE The source code repository for Test2 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 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 AsyncSubtest.pm100644001750001750 762614772042322 22364 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::AsyncSubtest; use strict; use warnings; our $VERSION = '1.302210'; 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. Always buffered. =item Do not use done_testing() yourself. using done_testing() inside an async subtest will not work properly, the async subtest must be finalized by calling C<< $st->finish >>. =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 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 ExitSummary.pm100644001750001750 360714772042322 22355 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Pluginpackage Test2::Plugin::ExitSummary; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Concurrency.pm100644001750001750 1031714772042322 22353 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manualpackage Test2::Manual::Concurrency; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Anatomy000755001750001750 014772042322 20751 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/ManualAPI.pm100644001750001750 360614772042322 22065 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Anatomypackage Test2::Manual::Anatomy::API; use strict; use warnings; our $VERSION = '1.302210'; 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 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 IPC.pm100644001750001750 506514772042322 22070 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Anatomypackage Test2::Manual::Anatomy::IPC; use strict; use warnings; our $VERSION = '1.302210'; 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 AFFECT 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 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 Task000755001750001750 014772042322 21004 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/WorkflowGroup.t100644001750001750 26114772042322 22404 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Workflow/Taskuse 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; 00test_harness_check.t100644001750001750 137414772042322 22355 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # A test to make sure the new Test::Harness was installed properly. use Test::More; plan tests => 1; my $TH_Version = 2.03; require Test::Harness; unless( cmp_ok( eval $Test::Harness::VERSION, '>=', $TH_Version, "T::H version" ) ) { diag < 1); Test::More::ok( !__PACKAGE__->can('ok'), 'plan should not export' ); tbt_08subtest.t100644001750001750 41414772042322 22310 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/env perl # HARNESS-NO-STREAM use strict; use warnings; use Test::Builder::Tester tests => 1; use Test::More; subtest 'foo' => sub { plan tests => 1; test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); }; line_numbers.t100644001750001750 742214772042322 22531 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # Test Test::More::subtest(), focusing on correct line numbers in # failed test diagnostics. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; } } use strict; use warnings; use Test::More tests => 5; use Test::Builder; use Test::Builder::Tester; # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; our %line; { test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1"); test_out(" not ok 2"); test_err(" # Failed test at $0 line $line{innerfail1}."); test_out(" ok 3"); test_err(" # Looks like you failed 1 test of 3."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{outerfail1}."); subtest namehere => sub { plan tests => 3; ok 1; ok 0; BEGIN{ $line{innerfail1} = __LINE__ } ok 1; }; BEGIN{ $line{outerfail1} = __LINE__ } test_test("un-named inner tests"); } { test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1 - first is good"); test_out(" not ok 2 - second is bad"); test_err(" # Failed test 'second is bad'"); test_err(" # at $0 line $line{innerfail2}."); test_out(" ok 3 - third is good"); test_err(" # Looks like you failed 1 test of 3."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{outerfail2}."); subtest namehere => sub { plan tests => 3; ok 1, "first is good"; ok 0, "second is bad"; BEGIN{ $line{innerfail2} = __LINE__ } ok 1, "third is good"; }; BEGIN{ $line{outerfail2} = __LINE__ } test_test("named inner tests"); } sub run_the_subtest { subtest namehere => sub { plan tests => 3; ok 1, "first is good"; ok 0, "second is bad"; BEGIN{ $line{innerfail3} = __LINE__ } ok 1, "third is good"; }; BEGIN{ $line{outerfail3} = __LINE__ } } { test_out("# Subtest: namehere"); test_out(" 1..3"); test_out(" ok 1 - first is good"); test_out(" not ok 2 - second is bad"); test_err(" # Failed test 'second is bad'"); test_err(" # at $0 line $line{innerfail3}."); test_out(" ok 3 - third is good"); test_err(" # Looks like you failed 1 test of 3."); test_out("not ok 1 - namehere"); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{outerfail3}."); run_the_subtest(); test_test("subtest() called from a sub"); } { test_out( "# Subtest: namehere"); test_out( " 1..0"); test_err( " # No tests run!"); test_out( 'not ok 1 - No tests run for subtest "namehere"'); test_err(q{# Failed test 'No tests run for subtest "namehere"'}); test_err( "# at $0 line $line{outerfail4}."); subtest namehere => sub { done_testing; }; BEGIN{ $line{outerfail4} = __LINE__ } test_test("lineno in 'No tests run' diagnostic"); } { test_out("# Subtest: namehere"); test_out(" 1..1"); test_out(" not ok 1 - foo is bar"); test_err(" # Failed test 'foo is bar'"); test_err(" # at $0 line $line{is_fail}."); test_err(" # got: 'foo'"); test_err(" # expected: 'bar'"); test_err(" # Looks like you failed 1 test of 1."); test_out('not ok 1 - namehere'); test_err("# Failed test 'namehere'"); test_err("# at $0 line $line{is_outer_fail}."); subtest namehere => sub { plan tests => 1; is 'foo', 'bar', 'foo is bar'; BEGIN{ $line{is_fail} = __LINE__ } }; BEGIN{ $line{is_outer_fail} = __LINE__ } test_test("diag indent for is() in subtest"); } current_test.t100644001750001750 44114772042322 22437 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # Dave Rolsky found a bug where if current_test() is used and no # tests are run via Test::Builder it will blow up. use strict; use warnings; use Test::Builder; my $TB = Test::Builder->new; $TB->plan(tests => 2); print "ok 1\n"; print "ok 2\n"; $TB->current_test(2); done_testing.t100644001750001750 35314772042322 22402 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->level(0); $tb->ok(1, "testing done_testing() with no arguments"); $tb->ok(1, " another test so we're not testing just one"); $tb->done_testing(); 817-subtest-todo.t100644001750001750 165414772042322 22304 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::API qw(run_subtest context intercept); use Test::More; use Test2::Tools::Tiny qw/todo/; sub aaa { my $ctx = context(); run_subtest( "bad pass", sub { local $TODO = "third test"; ok(1, "ok"); } ); $ctx->release; } sub bbb { my $ctx = context(); run_subtest( "bad fail", sub { local $TODO = "fourth test"; ok(0, "ok"); } ); $ctx->release; } my $events = intercept { Test::Builder->new->_add_ts_hooks(); aaa(); bbb(); }; is_deeply( $events->[1]->{subevents}->[0]->{amnesty}->[0], { tag => 'TODO', details => "third test" }, "Amnesty was set properly for first subtest assertion", ); is_deeply( $events->[3]->{subevents}->[0]->{amnesty}->[0], { tag => 'TODO', details => "fourth test" }, "Amnesty was set properly for second subtest assertion", ); done_testing; Generic.t100644001750001750 734314772042322 22262 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; use Test2::API qw/context intercept/; sub tool { my $ctx = context(); my $e = $ctx->send_event('Generic', @_); $ctx->release; return $e; } my $e; intercept { $e = tool() }; ok($e, "got event"); ok($e->isa('Test2::Event'), "It is an event"); ok($e->isa('Test2::Event::Generic'), "It is an event"); delete $e->{trace}; is_deeply( $e, { causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, _eid => $e->eid, hubs => [ { 'buffered' => 0, 'details' => 'Test2::Hub::Interceptor', 'hid' => $e->hubs->[0]->{hid}, 'ipc' => 0, 'nested' => 0, 'pid' => $$, 'tid' => 0, $e->hubs->[0]->{uuid} ? (uuid => $e->hubs->[0]->{uuid}) : (uuid => undef), } ], $e->uuid ? (uuid => $e->uuid) : (), }, "Defaults" ); for my $f (qw/causes_fail increments_count diagnostics no_display/) { is($e->$f, 0, "'$f' is 0"); is_deeply([$e->$f], [0], "'$f' is 0 is list context as well"); my $set = "set_$f"; $e->$set(1); is($e->$f, 1, "'$f' was set to 1"); } for my $f (qw/callback terminate global sets_plan/) { is($e->$f, undef, "no $f"); is_deeply([$e->$f], [], "$f is empty in list context"); } like($e->summary, qr/Test2::Event::Generic/, "Got base class summary"); like( exception { $e->set_sets_plan('bad') }, qr/'sets_plan' must be an array reference/, "Must provide an arrayref" ); $e->set_sets_plan([0, skip => 'cause']); is_deeply([$e->sets_plan], [0, skip => 'cause'], "sets_plan returns a list, not a ref"); $e->set_sets_plan(undef); ok(!exists $e->{sets_plan}, "Removed sets_plan key"); ok(!$e->sets_plan, "sets_plan is cleared"); $e->set_global(0); is($e->global, 0, "global is off"); $e->set_global(1); is($e->global, 1, "global is on"); $e->set_global(0); is($e->global, 0, "global is again"); $e->set_global(undef); ok(!exists $e->{global}, "removed global key"); is($e->global, undef, "global is not defined"); like( exception { $e->set_callback('dogfood') }, qr/callback must be a code reference/, "Callback must be code" ); my $ran = 0; $e->set_callback(sub { $ran++; my $self = shift; is($self, $e, "got self"); is_deeply( \@_, ['a', 'b', 'c'], "Got args" ); return 'foo'; }); is($e->callback('a', 'b', 'c'), 'foo', "got callback's return"); ok($ran, "ran callback"); $e->set_callback(undef); ok(!$e->callback, "no callback"); ok(!exists $e->{callback}, "no callback key"); like( exception { $e->set_terminate('1.1') }, qr/terminate must be a positive integer/, "terminate only takes integers" ); like( exception { $e->set_terminate('foo') }, qr/terminate must be a positive integer/, "terminate only takes numbers" ); like( exception { $e->set_terminate('-1') }, qr/terminate must be a positive integer/, "terminate only takes positive integers" ); $e->set_terminate(0), is($e->terminate, 0, "set to 0, 0 is valid"); $e->set_terminate(1), is($e->terminate, 1, "set to 1"); $e->set_terminate(123), is($e->terminate, 123, "set to 123"); $e->set_terminate(0), is($e->terminate, 0, "set to 0, 0 is valid"); $e->set_terminate(undef); is($e->terminate, undef, "terminate is not defined"); ok(!exists $e->{terminate}, "no terminate key"); # Test constructor args intercept { $e = tool(causes_fail => 1, increments_count => 'a') }; is($e->causes_fail, 1, "attr from constructor"); is($e->increments_count, 'a', "attr from constructor"); done_testing; Subtest.t100644001750001750 413414772042322 22332 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Subtest; my $st = 'Test2::Event::Subtest'; my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']); my $one = $st->new( trace => $trace, pass => 1, buffered => 1, name => 'foo', subtest_id => "1-1-1", ); ok($one->isa('Test2::Event::Ok'), "Inherit from Ok"); is_deeply($one->subevents, [], "subevents is an arrayref"); is($one->summary, "foo", "simple summary"); $one->set_todo(''); is($one->summary, "foo (TODO)", "simple summary + TODO"); $one->set_todo('foo'); is($one->summary, "foo (TODO: foo)", "simple summary + TODO + Reason"); $one->set_todo(undef); $one->set_name(''); is($one->summary, "Nameless Subtest", "unnamed summary"); require Test2::Event::Pass; push @{$one->subevents} => Test2::Event::Pass->new(name => 'xxx'); my $facet_data = $one->facet_data; ok($facet_data->{about}, "got parent facet data"); is_deeply( $facet_data->{parent}, { hid => "1-1-1", buffered => 1, children => [ { about => { details => 'pass', package => 'Test2::Event::Pass', eid => $one->subevents->[0]->eid, }, assert => { details => 'xxx', pass => 1 }, } ], }, "Got facet data" ); $one->{start_stamp} = 123; $one->{stop_stamp} = 456; $facet_data = $one->facet_data; is_deeply( $facet_data->{parent}, { hid => "1-1-1", buffered => 1, start_stamp => 123, stop_stamp => 456, children => [ { about => { details => 'pass', package => 'Test2::Event::Pass', eid => $one->subevents->[0]->eid, }, assert => { details => 'xxx', pass => 1 }, } ], }, "Got facet data with stamps" ); done_testing; Waiting.t100644001750001750 116614772042322 22305 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Waiting; my $waiting = Test2::Event::Waiting->new( trace => {}, ); ok($waiting, "Created event"); ok($waiting->global, "waiting is global"); is($waiting->summary, "IPC is waiting for children to finish...", "Got summary"); my $facet_data = $waiting->facet_data; ok($facet_data->{about}, "Got common facet data"); is_deeply( $facet_data->{info}, [ { tag => 'INFO', debug => 0, details => "IPC is waiting for children to finish...", }, ], "Got added info facet" ); done_testing; Formatter000755001750001750 014772042322 21234 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesTAP.t100644001750001750 10330414772042322 22246 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Formatteruse strict; use warnings; # HARNESS-NO-PRELOAD # HARNESS-NO-STREAM my $CLASS; my %BEFORE_LOAD; local $ENV{TABLE_TERM_SIZE} = 80; BEGIN { my $old = select STDOUT; $BEFORE_LOAD{STDOUT} = $|; select STDERR; $BEFORE_LOAD{STDERR} = $|; select $old; require Test2::Formatter::TAP; $CLASS = 'Test2::Formatter::TAP'; *OUT_STD = $CLASS->can('OUT_STD') or die "Could not get OUT_STD constant"; *OUT_ERR = $CLASS->can('OUT_ERR') or die "Could not get OUT_ERR constant"; } use Test2::Tools::Tiny; use Test2::API qw/context/; BEGIN { eval { require PerlIO; PerlIO->VERSION(1.02); # required for PerlIO::get_layers } or do { print "1..0 # SKIP Don't have PerlIO 1.02\n"; exit 0; } } sub grabber { my ($std, $err); open(my $stdh, '>', \$std) || die "Ooops"; open(my $errh, '>', \$err) || die "Ooops"; my $it = $CLASS->new( handles => [$stdh, $errh, $stdh], ); return ($it, \$std, \$err); } tests "IO handle stuff" => sub { ok($CLASS->can($_), "$CLASS has the '$_' method") for qw/no_numbers handles/; ok($CLASS->isa('Test2::Formatter'), "$CLASS isa Test2::Formatter"); ok(!$BEFORE_LOAD{STDOUT}, "AUTOFLUSH was not on for STDOUT before load"); ok(!$BEFORE_LOAD{STDERR}, "AUTOFLUSH was not on for STDERR before load"); my $old = select STDOUT; ok($|, "AUTOFLUSH was turned on for STDOUT"); select STDERR; ok($|, "AUTOFLUSH was turned on for STDERR"); select $old; ok(my $one = $CLASS->new, "Created a new instance"); my $handles = $one->handles; is(@$handles, 2, "Got 2 handles"); ok($handles->[0] != $handles->[1], "First and second handles are not the same"); my $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[0])}; if (${^UNICODE} & 2) { # 2 means STDIN ok($layers->{utf8}, "'S' is set in PERL_UNICODE, or in -C, honor it, utf8 should be on"); } else { ok(!$layers->{utf8}, "Not utf8 by default"); } $one->encoding('utf8'); is($one->encoding, 'utf8', "Got encoding"); $handles = $one->handles; is(@$handles, 2, "Got 2 handles"); $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[OUT_STD])}; ok($layers->{utf8}, "Now utf8"); my $two = $CLASS->new(encoding => 'utf8'); $handles = $two->handles; is(@$handles, 2, "Got 2 handles"); $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[OUT_STD])}; ok($layers->{utf8}, "Now utf8"); $old = select $handles->[OUT_STD]; ok($|, "AUTOFLUSH was turned on for copy-STDOUT"); select select $handles->[OUT_ERR]; ok($|, "AUTOFLUSH was turned on for copy-STDERR"); select $old; ok($CLASS->hide_buffered, "TAP will hide buffered events"); ok(!$CLASS->no_subtest_space, "Default formatter does not have subtest space"); }; tests optimal_pass => sub { my ($it, $out, $err) = grabber(); my $fail = Test2::Event::Fail->new; ok(!$it->print_optimal_pass($fail, 1), "Not gonna print a non-pass"); $fail = Test2::Event::Ok->new(pass => 0); ok(!$it->print_optimal_pass($fail, 1), "Not gonna print a non-pass"); my $pass = Test2::Event::Pass->new(); $pass->add_amnesty({tag => 'foo', details => 'foo'}); ok(!$it->print_optimal_pass($pass, 1), "Not gonna print amnesty"); $pass = Test2::Event::Ok->new(pass => 1, todo => ''); ok(!$it->print_optimal_pass($pass, 1), "Not gonna print todo (even empty todo)"); $pass = Test2::Event::Ok->new(pass => 1, name => "foo # bar"); ok(!$it->print_optimal_pass($pass, 1), "Not gonna pritn a name with a hash"); $pass = Test2::Event::Ok->new(pass => 1, name => "foo \n bar"); ok(!$it->print_optimal_pass($pass, 1), "Not gonna pritn a name with a newline"); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); $pass = Test2::Event::Pass->new(); ok($it->print_optimal_pass($pass, 1), "Printed a simple pass without a name"); $pass = Test2::Event::Pass->new(name => 'xxx'); ok($it->print_optimal_pass($pass, 1), "Printed a simple pass with a name"); $pass = Test2::Event::Ok->new(pass => 1, name => 'xxx'); ok($it->print_optimal_pass($pass, 1), "Printed an 'Ok' pass with a name"); $pass = Test2::Event::Pass->new(name => 'xxx', trace => {nested => 1}); ok($it->print_optimal_pass($pass, 1), "Printed a nested pass"); $pass = Test2::Event::Pass->new(name => 'xxx', trace => {nested => 3}); ok($it->print_optimal_pass($pass, 1), "Printed a deeply nested pass"); $pass = Test2::Event::Pass->new(name => 'xxx'); $it->{no_numbers} = 1; ok($it->print_optimal_pass($pass, 1), "Printed a simple pass with a name"); is($$out, <<" EOT", "Got expected TAP output"); ok 1 ok 1 - xxx ok 1 - xxx ok 1 - xxx ok 1 - xxx ok - xxx EOT is($it->{_last_fh}, $it->handles->[OUT_STD], "Set the last filehandle"); ok(!$$err, "No err output"); }; tests plan_tap => sub { my ($it, $out, $err) = grabber(); is_deeply([$it->plan_tap({})], [], "Nothing with no plan facet"); is_deeply( [$it->plan_tap({plan => {none => 1}})], [], "no-plan has no output" ); is_deeply( [$it->plan_tap({plan => {count => 20}})], [[OUT_STD, "1..20\n"]], "Wrote the plan from, count" ); is_deeply( [$it->plan_tap({plan => {count => 'anything', skip => 1}})], [[OUT_STD, "1..0 # SKIP\n"]], "Skip, no reason" ); is_deeply( [$it->plan_tap({plan => {count => 'anything', skip => 1, details => 'I said so'}})], [[OUT_STD, "1..0 # SKIP I said so\n"]], "Skip with reason" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests assert_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->assert_tap({assert => {pass => 1}}, 1)], [[OUT_STD, "ok 1\n"]], "Pass", ); is_deeply( [$it->assert_tap({assert => {pass => 0}}, 1)], [[OUT_STD, "not ok 1\n"]], "Fail", ); tests amnesty => sub { tests pass_no_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "ok 1 # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "ok 1 # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 1}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "ok 1 # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 # foo xxx\n"]], "Pass with other amnesty", ); }; tests pass_with_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 - bob # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "ok 1 - bob # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 - bob # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "ok 1 - bob # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 1, details => 'bob'}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "ok 1 - bob # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "ok 1 - bob # foo xxx\n"]], "Pass with other amnesty", ); }; tests fail_no_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "not ok 1 # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "not ok 1 # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 0}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "not ok 1 # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 # foo xxx\n"]], "Pass with other amnesty", ); }; tests fail_with_name => sub { is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 - bob # skip xxx\n"]], "Pass with skip (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'skip'}]}, 1)], [[OUT_STD, "not ok 1 - bob # skip\n"]], "Pass with skip (without details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 - bob # TODO xxx\n"]], "Pass with TODO (with details)", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'TODO'}]}, 1)], [[OUT_STD, "not ok 1 - bob # TODO\n"]], "Pass with TODO (without details)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 0, details => 'bob'}, amnesty => [ {tag => 'TODO', details => 'xxx'}, {tag => 'skip', details => 'yyy'}, ] }, 1 ) ], [[OUT_STD, "not ok 1 - bob # TODO & SKIP yyy\n"]], "Pass with skip and TODO", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], [[OUT_STD, "not ok 1 - bob # foo xxx\n"]], "Pass with other amnesty", ); }; }; tests newline_and_hash => sub { tests pass => sub { is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo\nbar"}}, 1)], [ [OUT_STD, "ok 1 - foo\n"], [OUT_STD, "# bar\n"], ], "Pass with newline", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo\nbar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "ok 1 - foo # baz bat\n"], [OUT_STD, "# bar\n"], ], "Pass with newline and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#bar"}}, 1)], [[OUT_STD, "ok 1 - foo\\#bar\n"]], "Pass with hash", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#bar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [[OUT_STD, "ok 1 - foo\\#bar # baz bat\n"]], "Pass with hash and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#x\nbar#boo"}}, 1)], [ [OUT_STD, "ok 1 - foo\\#x\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash", ); is_deeply( [$it->assert_tap({assert => {pass => 1, details => "foo#x\nbar#boo"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "ok 1 - foo\\#x # baz bat\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash and amnesty", ); }; tests fail => sub { is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo\nbar"}}, 1)], [ [OUT_STD, "not ok 1 - foo\n"], [OUT_STD, "# bar\n"], ], "Pass with newline", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo\nbar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "not ok 1 - foo # baz bat\n"], [OUT_STD, "# bar\n"], ], "Pass with newline and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#bar"}}, 1)], [[OUT_STD, "not ok 1 - foo\\#bar\n"]], "Pass with hash", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#bar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [[OUT_STD, "not ok 1 - foo\\#bar # baz bat\n"]], "Pass with hash and amnesty", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#x\nbar#boo"}}, 1)], [ [OUT_STD, "not ok 1 - foo\\#x\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash", ); is_deeply( [$it->assert_tap({assert => {pass => 0, details => "foo#x\nbar#boo"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], [ [OUT_STD, "not ok 1 - foo\\#x # baz bat\n"], [OUT_STD, "# bar#boo\n"], ], "Pass with newline and hash and amnesty", ); }; }; tests parent => sub { is_deeply( [ $it->assert_tap( { assert => {pass => 1, details => 'bob'}, parent => {hid => 1, buffered => 1, children => [{assert => {pass => 1, details => 'bob2'}}]}, }, 1 ) ], [ [OUT_STD, "ok 1 - bob {\n"], [OUT_STD, " ok 1 - bob2\n"], [OUT_STD, "}\n"], ], "Parent (buffered)", ); is_deeply( [ $it->assert_tap( { assert => {pass => 1, details => 'bob'}, parent => {hid => 1, buffered => 0, children => [{assert => {pass => 1, details => 'bob2'}}]}, }, 1 ) ], [[OUT_STD, "ok 1 - bob\n"]], "Parent (un-buffered)", ); }; ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests debug_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [ $it->debug_tap( { assert => {pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, }, 1 ) ], [ [OUT_ERR, "# Failed test at foo.t line 42.\n"], ], "debug tap, nameless test" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# at foo.t line 42.\n"], ], "Debug tap, named test" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42], details => 'I say hi!'}, }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# I say hi!\n"], ], "Debug tap with details" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# [No trace info available]\n"], ], "Debug tap no trace" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, amnesty => [], }, 1 ) ], [ [OUT_ERR, "# Failed test 'foo bar'\n# at foo.t line 42.\n"], ], "Debug empty amnesty" ); is_deeply( [ $it->debug_tap( { assert => {details => 'foo bar', pass => 0}, trace => {frame => ['foo', 'foo.t', 42]}, amnesty => [{tag => 'TODO', details => 'xxx'}], }, 1 ) ], [ [OUT_STD, "# Failed test (with amnesty) 'foo bar'\n# at foo.t line 42.\n"], ], "Debug empty amnesty" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); my $event = Test2::Event::Fail->new(trace => {frame => ['foo', 'foo.pl', 42]}); { local $ENV{HARNESS_ACTIVE} = 0; local $ENV{HARNESS_IS_VERBOSE} = 0; $event->{name} = 'no harness'; $it->write($event, 1); $ENV{HARNESS_ACTIVE} = 0; $ENV{HARNESS_IS_VERBOSE} = 1; $event->{name} = 'no harness, but strangely verbose'; $it->write($event, 1); $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_IS_VERBOSE} = 0; $event->{name} = 'harness, but not verbose'; $it->write($event, 1); $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_IS_VERBOSE} = 1; $event->{name} = 'harness that is verbose'; $it->write($event, 1); } is($$out, <<" EOT", "Got 4 failures to STDERR"); not ok 1 - no harness not ok 1 - no harness, but strangely verbose not ok 1 - harness, but not verbose not ok 1 - harness that is verbose EOT is($$err, <<" EOT", "Got expected diag to STDERR, newline for non-verbose harness"); # Failed test 'no harness' # at foo.pl line 42. # Failed test 'no harness, but strangely verbose' # at foo.pl line 42. # Failed test 'harness, but not verbose' # at foo.pl line 42. # Failed test 'harness that is verbose' # at foo.pl line 42. EOT }; tests halt_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->halt_tap({trace => {nested => 1},})], [], "No output when nested" ); is_deeply( [$it->halt_tap({trace => {nested => 1, buffered => 1}})], [[OUT_STD, "Bail out!\n"]], "Got tap for nested buffered bail" ); is_deeply( [$it->halt_tap({control => {details => ''}})], [[OUT_STD, "Bail out!\n"]], "Empty details" ); is_deeply( [$it->halt_tap({control => {details => undef}})], [[OUT_STD, "Bail out!\n"]], "undef details" ); is_deeply( [$it->halt_tap({control => {details => 0}})], [[OUT_STD, "Bail out! 0\n"]], "falsy details" ); is_deeply( [$it->halt_tap({control => {details => 'foo bar baz'}})], [[OUT_STD, "Bail out! foo bar baz\n"]], "full details" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests summary_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->summary_tap({about => {no_display => 1, details => "Should not see me"}})], [], "no display" ); is_deeply( [$it->summary_tap({about => {no_display => 0, details => ""}})], [], "no summary" ); is_deeply( [$it->summary_tap({about => {no_display => 0, details => "foo bar"}})], [[OUT_STD, "# foo bar\n"]], "summary" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests info_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [ $it->info_tap( { info => [ {debug => 0, details => "foo"}, {debug => 1, details => "foo"}, {debug => 0, details => "foo\nbar\nbaz"}, {debug => 1, details => "foo\nbar\nbaz"}, ] } ) ], [ [OUT_STD, "# foo\n"], [OUT_ERR, "# foo\n"], [OUT_STD, "# foo\n# bar\n# baz\n"], [OUT_ERR, "# foo\n# bar\n# baz\n"], ], "Got all infos" ); my @TAP = $it->info_tap( { info => [ {debug => 0, details => {structure => 'yes'}}, {debug => 1, details => {structure => 'yes'}}, ] } ); is($TAP[0]->[0], OUT_STD, "First went to STDOUT"); is($TAP[1]->[0], OUT_ERR, "Second went to STDOUT"); like($TAP[0]->[1], qr/structure.*=>.*yes/, "We see the structure in some form"); like($TAP[1]->[1], qr/structure.*=>.*yes/, "We see the structure in some form"); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests error_tap => sub { my ($it, $out, $err) = grabber(); # Data::Dumper behavior can change from version to version, specifically # the Data::Dumper in 5.8.9 produces different whitespace from other # versions. require Data::Dumper; my $dumper = Data::Dumper->new([{structure => 'yes'}])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp(my $struct = $dumper->Dump); is_deeply( [ $it->error_tap( { errors => [ {details => "foo"}, {details => "foo\nbar\nbaz"}, {details => {structure => 'yes'}}, ] } ) ], [ [OUT_ERR, "# foo\n"], [OUT_ERR, "# foo\n# bar\n# baz\n"], [OUT_ERR, "$struct\n"], ], "Got all errors" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests event_tap => sub { my ($it, $out, $err) = grabber(); is_deeply( [$it->event_tap({plan => {count => 5}, assert => {pass => 1}}, 1)], [ [OUT_STD, "1..5\n"], [OUT_STD, "ok 1\n"], ], "Plan then assertion for first assertion" ); $it->{made_assertion} = 1; is_deeply( [$it->event_tap({plan => {count => 5}, assert => {pass => 1}}, 2)], [ [OUT_STD, "ok 2\n"], [OUT_STD, "1..5\n"], ], "Assertion then plan for additional assertions" ); $it->{made_assertion} = 0; is_deeply( [ $it->event_tap( { plan => {count => 5}, assert => {pass => 0}, errors => [{details => "foo"}], info => [ {tag => 'DIAG', debug => 1, details => 'xxx'}, {tag => 'NOTE', debug => 0, details => 'yyy'}, ], control => {halt => 1, details => 'blah'}, about => {details => 'xyz'}, }, 1 ) ], [ [OUT_STD, "1..5\n"], [OUT_STD, "not ok 1\n"], [OUT_ERR, "# Failed test [No trace info available]\n"], [OUT_ERR, "# foo\n"], [OUT_ERR, "# xxx\n"], [OUT_STD, "# yyy\n"], [OUT_STD, "Bail out! blah\n"], ], "All facets displayed" ); is_deeply( [ $it->event_tap( { plan => {count => 5}, about => {details => 'xyz'}, }, 1 ) ], [[OUT_STD, "1..5\n"]], "Plan blocks details" ); is_deeply( [ $it->event_tap( { assert => {pass => 0, no_debug => 1}, about => {details => 'xyz'}, }, 1 ) ], [[OUT_STD, "not ok 1\n"]], "Assert blocks details" ); is_deeply( [ $it->event_tap( { errors => [{details => "foo"}], about => {details => 'xyz'}, }, 1 ) ], [[OUT_ERR, "# foo\n"]], "Error blocks details" ); is_deeply( [ $it->event_tap( { info => [ {tag => 'DIAG', debug => 1, details => 'xxx'}, {tag => 'NOTE', debug => 0, details => 'yyy'}, ], about => {details => 'xyz'}, }, 1 ) ], [ [OUT_ERR, "# xxx\n"], [OUT_STD, "# yyy\n"], ], "Info blocks details" ); is_deeply( [ $it->event_tap( { control => {halt => 1, details => 'blah'}, about => {details => 'xyz'}, }, 1 ) ], [[OUT_STD, "Bail out! blah\n"]], "Halt blocks details" ); is_deeply( [$it->event_tap({about => {details => 'xyz'}}, 1)], [[OUT_STD, "# xyz\n"]], "Fallback to summary" ); ok(!$$out, "No std output yet"); ok(!$$err, "No err output yet"); }; tests write => sub { my ($it, $out, $err) = grabber(); local $ENV{HARNESS_ACTIVE} = 0; local $ENV{HARNESS_IS_VERBOSE} = 0; { local $\ = 'oops1'; local $, = 'oops2'; $it->write( undef, 1, { plan => {count => 5}, assert => {pass => 0}, errors => [{details => "foo"}], info => [ {tag => 'DIAG', debug => 1, details => 'xxx'}, {tag => 'NOTE', debug => 0, details => 'yyy'}, ], control => {halt => 1, details => 'blah'}, about => {details => 'xyz'}, }, ); $it->write(undef, 2, {assert => {pass => 1}, trace => {nested => 1}}); } is($it->{_last_fh}, $it->handles->[OUT_STD], "Set last handle"); is($$out, <<" EOT", "STDOUT is as expected"); 1..5 not ok 1 # yyy Bail out! blah ok 2 EOT is($$err, <<" EOT", "STDERR is as expected"); # Failed test [No trace info available] # foo # xxx EOT }; my $can_table = $CLASS->supports_tables; my $author_testing = $ENV{AUTHOR_TESTING}; if ($author_testing && !$can_table) { die "You are running this test under AUTHOR_TESTING, doing so requires Term::Table to be installed, but it is not currently installed, this is a fatal error. Please install Term::Table before attempting to run this test under AUTHOR_TESTING."; } elsif ($can_table) { tests tables => sub { my ($it, $out, $err) = grabber(); no warnings 'redefine'; local *Term::Table::Util::term_size = sub { 70 }; my %table_data = ( header => ['H1', 'H2'], rows => [ ["R1C1\n", 'R1C2'], ['R2C1', 'R2C2'], [('x' x 30), ('y' x 30)], ], ); { local *Test2::Formatter::TAP::supports_tables = sub { 0 }; $it->write( undef, 1, { info => [ { tag => 'DIAG', details => 'should see only this', debug => 1, table => \%table_data, }, { tag => 'NOTE', details => 'should see only this', table => \%table_data, }, ] }, ); } $it->write( undef, 1, { info => [ { tag => 'DIAG', details => 'should not see', debug => 1, table => \%table_data, }, { tag => 'NOTE', details => 'should not see', table => \%table_data, }, ] }, ); $it->write( undef, 1, { trace => {nested => 2}, info => [ { tag => 'DIAG', details => 'should not see', debug => 1, table => \%table_data, }, { tag => 'NOTE', details => 'should not see', table => \%table_data, }, ] }, ); my $table1 = join "\n" => map { "# $_" } Term::Table->new( %table_data, max_width => Term::Table::Util::term_size() - 2, # 2 for '# ' collapse => 1, sanitize => 1, mark_tail => 1, )->render; my $table2 = join "\n" => map { " # $_" } Term::Table->new( %table_data, max_width => Term::Table::Util::term_size() - 10, # 2 for '# ', 8 for indentation collapse => 1, sanitize => 1, mark_tail => 1, )->render; is($$out, <<" EOT", "Showed detail OR tables, properly sized and indented in STDOUT"); # should see only this $table1 $table2 EOT is($$err, <<" EOT", "Showed detail OR tables, properly sized and indented in STDERR"); # should see only this $table1 $table2 EOT }; } done_testing; Subtest_todo.t100644001750001750 164414772042322 22430 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept/; my $events = intercept { todo 'testing todo', sub { run_subtest( 'fails in todo', sub { ok(1, 'first passes'); ok(0, 'second fails'); } ); }; }; ok($events->[1], 'Test2::Event::Subtest', 'subtest ran'); ok($events->[1]->effective_pass, 'Test2::Event::Subtest', 'subtest effective_pass is true'); ok($events->[1]->todo, 'testing todo', 'subtest todo is set to expected value'); my $subevents = $events->[1]->subevents; is(scalar @$subevents, 3, 'got subevents in the subtest'); ok($subevents->[0]->facets->{assert}->pass, 'first event passed'); ok(!$subevents->[1]->facets->{assert}->pass, 'second event failed'); ok(!$subevents->[1]->causes_fail, 'second event does not cause failure'); done_testing; trace_stamps.t100644001750001750 73514772042322 22417 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw{ intercept test2_enable_trace_stamps test2_disable_trace_stamps test2_trace_stamps_enabled }; test2_enable_trace_stamps(); my $events = intercept { ok(1, "pass"); }; ok($events->[0]->facet_data->{trace}->{stamp}, "got stamp"); test2_disable_trace_stamps(); $events = intercept { ok(1, "pass"); }; ok(!exists($events->[0]->facet_data->{trace}->{stamp}), "no stamp"); done_testing; Task000755001750001750 014772042322 20640 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/WorkflowGroup.pm100644001750001750 416614772042322 22441 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Workflow/Taskpackage Test2::Workflow::Task::Group; use strict; use warnings; our $VERSION = '1.302210'; 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 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 InterceptResult.pm100644001750001750 4334514772042322 22420 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/APIpackage Test2::API::InterceptResult; use strict; use warnings; our $VERSION = '1.302210'; use Scalar::Util qw/blessed/; use Test2::Util qw/pkg_to_file/; use Storable qw/dclone/; use Carp qw/croak/; use Test2::API::InterceptResult::Squasher; use Test2::API::InterceptResult::Event; use Test2::API::InterceptResult::Hub; sub new { croak "Called a method that creates a new instance in void context" unless defined wantarray; my $class = shift; bless([@_], $class); } sub new_from_ref { croak "Called a method that creates a new instance in void context" unless defined wantarray; bless($_[1], $_[0]); } sub clone { blessed($_[0])->new(@{dclone($_[0])}) } sub event_list { @{$_[0]} } sub _upgrade { my $self = shift; my ($event, %params) = @_; my $blessed = blessed($event); my $upgrade_class = $params{upgrade_class} ||= 'Test2::API::InterceptResult::Event'; return $event if $blessed && $event->isa($upgrade_class) && !$params{_upgrade_clone}; my $fd = dclone($blessed ? $event->facet_data : $event); my $class = $params{result_class} ||= blessed($self); if (my $parent = $fd->{parent}) { $parent->{children} = $class->new_from_ref($parent->{children} || [])->upgrade(%params); } my $uc_file = pkg_to_file($upgrade_class); require($uc_file) unless $INC{$uc_file}; return $upgrade_class->new(facet_data => $fd, result_class => $class); } sub hub { my $self = shift; my $hub = Test2::API::InterceptResult::Hub->new(); $hub->process($_) for @$self; $hub->set_ended(1); return $hub; } sub state { my $self = shift; my %params = @_; my $hub = $self->hub; my $out = { map {($_ => scalar $hub->$_)} qw/count failed is_passing plan bailed_out skip_reason/ }; $out->{bailed_out} = $self->_upgrade($out->{bailed_out}, %params)->bailout_reason || 1 if $out->{bailed_out}; $out->{follows_plan} = $hub->check_plan; return $out; } sub upgrade { my $self = shift; my %params = @_; my @out = map { $self->_upgrade($_, %params, _upgrade_clone => 1) } @$self; return blessed($self)->new_from_ref(\@out) unless $params{in_place}; @$self = @out; return $self; } sub squash_info { my $self = shift; my %params = @_; my @out; { my $squasher = Test2::API::InterceptResult::Squasher->new(events => \@out); # Clone to make sure we do not indirectly modify an existing one if it # is already upgraded $squasher->process($self->_upgrade($_, %params)->clone) for @$self; $squasher->flush_down(); } return blessed($self)->new_from_ref(\@out) unless $params{in_place}; @$self = @out; return $self; } sub asserts { shift->grep(has_assert => @_) } sub subtests { shift->grep(has_subtest => @_) } sub diags { shift->grep(has_diags => @_) } sub notes { shift->grep(has_notes => @_) } sub errors { shift->grep(has_errors => @_) } sub plans { shift->grep(has_plan => @_) } sub causes_fail { shift->grep(causes_fail => @_) } sub causes_failure { shift->grep(causes_failure => @_) } sub flatten { shift->map(flatten => @_) } sub briefs { shift->map(brief => @_) } sub summaries { shift->map(summary => @_) } sub subtest_results { shift->map(subtest_result => @_) } sub diag_messages { shift->map(diag_messages => @_) } sub note_messages { shift->map(note_messages => @_) } sub error_messages { shift->map(error_messages => @_) } no warnings 'once'; *map = sub { my $self = shift; my ($call, %params) = @_; my $args = $params{args} ||= []; return [map { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self]; }; *grep = sub { my $self = shift; my ($call, %params) = @_; my $args = $params{args} ||= []; my @out = grep { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self; return blessed($self)->new_from_ref(\@out) unless $params{in_place}; @$self = @out; return $self; }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult - Representation of a list of events. =head1 DESCRIPTION This class represents a list of events, normally obtained using C from L. This class is intended for people who with to verify the results of test tools they write. This class provides methods to normalize, summarize, or map the list of events. The output of these operations makes verifying your testing tools and the events they generate significantly easier. In most cases this spares you from needing a deep understanding of the event/facet model. =head1 SYNOPSIS Usually you get an instance of this class when you use C from L. use Test2::V0; use Test2::API qw/intercept/; my $events = intercept { ok(1, "pass"); ok(0, "fail"); todo "broken" => sub { ok(0, "fixme") }; plan 3; }; # This is typically the most useful construct # squash_info() merges assertions and diagnostics that are associated # (and returns a new instance with the modifications) # flatten() condenses the facet data into the key details for each event # (and returns those structures in an arrayref) is( $events->squash_info->flatten(), [ { causes_failure => 0, name => 'pass', pass => 1, trace_file => 'xxx.t', trace_line => 5, }, { causes_failure => 1, name => 'fail', pass => 0, trace_file => 'xxx.t', trace_line => 6, # There can be more than one diagnostics message so this is # always an array when present. diag => ["Failed test 'fail'\nat xxx.t line 6."], }, { causes_failure => 0, name => 'fixme', pass => 0, trace_file => 'xxx.t', trace_line => 7, # There can be more than one diagnostics message or todo # reason, so these are always an array when present. todo => ['broken'], # Diag message was turned into a note since the assertion was # TODO note => ["Failed test 'fixme'\nat xxx.t line 7."], }, { causes_failure => 0, plan => 3, trace_file => 'xxx.t', trace_line => 8, }, ], "Flattened events look like we expect" ); See L for a full description of what C provides for each event. =head1 METHODS Please note that no methods modify the original instance unless asked to do so. =head2 CONSTRUCTION =over 4 =item $events = Test2::API::InterceptResult->new(@EVENTS) =item $events = Test2::API::InterceptResult->new_from_ref(\@EVENTS) These create a new instance of Test2::API::InterceptResult from the given events. In the first form a new blessed arrayref is returned. In the 'new_from_ref' form the reference you pass in is directly blessed. Both of these will throw an exception if called in void context. This is mainly important for the 'filtering' methods listed below which normally return a new instance, they throw an exception in such cases as it probably means someone meant to filter the original in place. =item $clone = $events->clone() Make a clone of the original events. Note that this is a deep copy, the entire structure is duplicated. This uses C from L to achieve the deep clone. =back =head2 NORMALIZATION =over 4 =item @events = $events->event_list This returns all the events in list-form. =item $hub = $events->hub This returns a new L instance that has processed all the events contained in the instance. This gives you a simple way to inspect the state changes your events cause. =item $state = $events->state This returns a summary of the state of a hub after processing all the events. { count => 2, # Number of assertions made failed => 1, # Number of test failures seen is_passing => 0, # Boolean, true if the test would be passing # after the events are processed. plan => 2, # Plan, either a number, undef, 'SKIP', or 'NO PLAN' follows_plan => 1, # True if there is a plan and it was followed. # False if the plan and assertions did not # match, undef if no plan was present in the # event list. bailed_out => undef, # undef unless there was a bail-out in the # events in which case this will be a string # explaining why there was a bailout, if no # reason was given this will simply be set to # true (1). skip_reason => undef, # If there was a skip_all this will give the # reason. } =item $new = $events->upgrade =item $events->upgrade(in_place => $BOOL) B This normally returns a new instance, leaving the original unchanged. If you call it in void context it will throw an exception. If you want to modify the original you must pass in the C<< in_place => 1 >> option. You may call this in void context when you ask to modify it in place. The in-place form returns the instance that was modified so you can chain methods. This will create a clone of the list where all events have been converted into L instances. This is extremely helpful as L provide a much better interface for working with events. This allows you to avoid thinking about legacy event types. This also means your tests against the list are not fragile if the tool you are testing randomly changes what type of events it generates (IE Changing from L to L, both make assertions and both will normalize to identical (or close enough) L instances. Really you almost always want this, the only reason it is not done automatically is to make sure the C tool is backwards compatible. =item $new = $events->squash_info =item $events->squash_info(in_place => $BOOL) B This normally returns a new instance, leaving the original unchanged. If you call it in void context it will throw an exception. If you want to modify the original you must pass in the C<< in_place => 1 >> option. You may call this in void context when you ask to modify it in place. The in-place form returns the instance that was modified so you can chain methods. B All events in the new or modified instance will be converted to L instances. There is no way to avoid this, the squash operation requires the upgraded event class. L and many other legacy tools would send notes, diags, and assertions as separate events. A subtest in L would send a note with the subtest name, the subtest assertion, and finally a diagnostics event if the subtest failed. This method will normalize things by squashing the note and diag into the same event as the subtest (This is different from putting them into the subtest, which is not what happens). =back =head2 FILTERING B These normally return new instances, leaving the originals unchanged. If you call them in void context they will throw exceptions. If you want to modify the originals you must pass in the C<< in_place => 1 >> option. You may call these in void context when you ask to modify them in place. The in-place forms return the instance that was modified so you can chain methods. =head3 %PARAMS These all accept the same 2 optional parameters: =over 4 =item in_place => $BOOL When true the method will modify the instance in place instead of returning a new instance. =item args => \@ARGS If you wish to pass parameters into the event method being used for filtering, you may do so here. =back =head3 METHODS =over 4 =item $events->grep($CALL, %PARAMS) This is essentially: Test2::API::InterceptResult->new( grep { $_->$CALL( @{$PARAMS{args}} ) } $self->event_list, ); B that $CALL is called on an upgraded version of the event, though the events returned will be the original ones, not the upgraded ones. $CALL may be either the name of a method on L, or a coderef. =item $events->asserts(%PARAMS) This is essentially: $events->grep(has_assert => @{$PARAMS{args}}) It returns a new instance containing only the events that made assertions. =item $events->subtests(%PARAMS) This is essentially: $events->grep(has_subtest => @{$PARAMS{args}}) It returns a new instance containing only the events that have subtests. =item $events->diags(%PARAMS) This is essentially: $events->grep(has_diags => @{$PARAMS{args}}) It returns a new instance containing only the events that have diags. =item $events->notes(%PARAMS) This is essentially: $events->grep(has_notes => @{$PARAMS{args}}) It returns a new instance containing only the events that have notes. =item $events->errors(%PARAMS) B Errors are NOT failing assertions. Failing assertions are a different thing. This is essentially: $events->grep(has_errors => @{$PARAMS{args}}) It returns a new instance containing only the events that have errors. =item $events->plans(%PARAMS) This is essentially: $events->grep(has_plan => @{$PARAMS{args}}) It returns a new instance containing only the events that set the plan. =item $events->causes_fail(%PARAMS) =item $events->causes_failure(%PARAMS) These are essentially: $events->grep(causes_fail => @{$PARAMS{args}}) $events->grep(causes_failure => @{$PARAMS{args}}) B C and C are both aliases for eachother in events, so these methods are effectively aliases here as well. It returns a new instance containing only the events that cause failure. =back =head2 MAPPING These methods B return an arrayref. B No methods on L alter the event in any way. B: L was tailor-made to be used in event-lists. Most methods that are not applicable to a given event will return an empty list, so you normally do not need to worry about unwanted C values or exceptions being thrown. Mapping over event methods is an intended use, so it works well to produce lists. B Some methods such as C always return a boolean true or false for all events. Any method prefixed with C conveys the intent that the event should have exactly 1 of something, so those will throw an exception when that condition is not true. =over 4 =item $arrayref = $events->map($CALL, %PARAMS) This is essentially: [ map { $_->$CALL(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; $CALL may be either the name of a method on L, or a coderef. =item $arrayref = $events->flatten(%PARAMS) This is essentially: [ map { $_->flatten(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of flattened structures. See L for details on what C returns. =item $arrayref = $events->briefs(%PARAMS) This is essentially: [ map { $_->briefs(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of event briefs. See L for details on what C returns. =item $arrayref = $events->summaries(%PARAMS) This is essentially: [ map { $_->summaries(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of event summaries. See L for details on what C returns. =item $arrayref = $events->subtest_results(%PARAMS) This is essentially: [ map { $_->subtest_result(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of event summaries. See L for details on what C returns. =item $arrayref = $events->diag_messages(%PARAMS) This is essentially: [ map { $_->diag_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of diagnostic messages (strings). See L for details on what C returns. =item $arrayref = $events->note_messages(%PARAMS) This is essentially: [ map { $_->note_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of notification messages (strings). See L for details on what C returns. =item $arrayref = $events->error_messages(%PARAMS) This is essentially: [ map { $_->error_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of error messages (strings). See L for details on what C returns. =back =head1 SOURCE The source code repository for Test2 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 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 Contributing.pm100644001750001750 522614772042322 22513 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manualpackage Test2::Manual::Contributing; our $VERSION = '1.302210'; 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/test-more 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 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 Hubs.pm100644001750001750 666314772042322 22363 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Anatomypackage Test2::Manual::Anatomy::Hubs; use strict; use warnings; our $VERSION = '1.302210'; 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 affecting 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 affected. =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 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 Testing000755001750001750 014772042322 20756 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/ManualTodo.pm100644001750001750 536314772042322 22370 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Testingpackage Test2::Manual::Testing::Todo; use strict; use warnings; our $VERSION = '1.302210'; 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 C and C 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 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 CaptureRunner.pm100644001750001750 241414772042322 22604 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Tester# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $ use strict; package Test::Tester::CaptureRunner; our $VERSION = '1.302210'; use Test::Tester::Capture; require Exporter; sub new { my $pkg = shift; my $self = bless {}, $pkg; return $self; } sub run_tests { my $self = shift; my $test = shift; capture()->reset; $self->{StartLevel} = $Test::Builder::Level; &$test(); } sub get_results { my $self = shift; my @results = capture()->details; my $start = $self->{StartLevel}; foreach my $res (@results) { next if defined $res->{depth}; my $depth = $res->{_depth} - $res->{_level} - $start - 3; # print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n"; $res->{depth} = $depth; } return @results; } sub get_premature { return capture()->premature; } sub capture { return Test::Tester::Capture->new; } __END__ =head1 NAME Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder =head1 DESCRIPTION This stuff if needed to allow me to play with other ways of monitoring the test results. =head1 AUTHOR Copyright 2003 by Fergal Daly . =head1 LICENSE Under the same license as Perl itself See L =cut Tester000755001750001750 014772042322 20676 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/BuilderColor.pm100644001750001750 171514772042322 22456 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test/Builder/Testerpackage Test::Builder::Tester::Color; use strict; our $VERSION = '1.302210'; require Test::Builder::Tester; =head1 NAME Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester =head1 SYNOPSIS When running a test script perl -MTest::Builder::Tester::Color test.t =head1 DESCRIPTION Importing this module causes the subroutine color in Test::Builder::Tester to be called with a true value causing colour highlighting to be turned on in debug output. The sole purpose of this module is to enable colour highlighting from the command line. =cut sub import { Test::Builder::Tester::color(1); } =head1 AUTHOR Copyright Mark Fowler Emark@twoshortplanks.comE 2002. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 BUGS This module will have no effect unless Term::ANSIColor is installed. =head1 SEE ALSO L, L =cut 1; Action.t100644001750001750 16214772042322 22525 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Workflow/Taskuse Test2::Bundle::Extended -target => 'Test2::Workflow::Task::Action'; can_ok($CLASS, 'around'); done_testing; LineBreak.t100644001750001750 313214772042322 22414 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Util/Tableuse 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; ClassicCompare.t100644001750001750 2074014772042322 22630 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse 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 separate 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; $warning = 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; }, ); } my $warnings; note "cmp_ok() displaying bad numbers"; { my $have = "zero"; my $want = "3point5"; like( intercept { $warnings = 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; no_leaks_no_threads.t100644001750001750 131714772042322 22747 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/behavioruse 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; tbt_04line_num.t100644001750001750 30414772042322 22417 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl use Test::More tests => 3; use Test::Builder::Tester; is(line_num(),6,"normal line num"); is(line_num(-1),6,"line number minus one"); is(line_num(+2),10,"line number plus two"); tbt_05faildiag.t100644001750001750 147014772042322 22377 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl use Test::Builder::Tester tests => 5; use Test::More; # test_fail test_out("not ok 1 - one"); test_fail(+1); ok(0,"one"); test_out("not ok 2 - two"); test_fail(+2); ok(0,"two"); test_test("test fail"); test_fail(+2); test_out("not ok 1 - one"); ok(0,"one"); test_test("test_fail first"); # test_diag use Test::Builder; my $test = new Test::Builder; test_diag("this is a test string","so is this"); $test->diag("this is a test string\n", "so is this\n"); test_test("test diag"); test_diag("this is a test string","so is this"); $test->diag("this is a test string\n"); $test->diag("so is this\n"); test_test("test diag multi line"); test_diag("this is a test string"); test_diag("so is this"); $test->diag("this is a test string\n"); $test->diag("so is this\n"); test_test("test diag multiple"); implicit_done.t100644001750001750 73714772042322 22650 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/subtest#!/usr/bin/perl -w # A subtest without a plan implicitly calls "done_testing" use strict; use Test::More; pass "Before"; subtest 'basic' => sub { pass "Inside sub test"; }; subtest 'with done' => sub { pass 'This has done_testing'; done_testing; }; subtest 'with plan' => sub { plan tests => 1; pass 'I have a plan, Batman!'; }; subtest 'skipping' => sub { plan skip_all => 'Skipping'; fail 'Shouldnt see me!'; }; pass "After"; done_testing; 736_use_ok.t100644001750001750 142014772042322 22352 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Regressionuse warnings; use strict; use Test::More; BEGIN { $INC{'MyWarner.pm'} = 1; package MyWarner; sub import { warnings::warnif('deprecated', "Deprecated! run for your lives!"); } } sub capture(&) { my $warn; local $SIG{__WARN__} = sub { $warn = shift }; $_[0]->(); return $warn || ""; } { local $TODO = "known to fail on $]" if "$]" <= 5.006002; my $file = __FILE__; my $line = __LINE__ + 4; like( capture { local $TODO; # localize $TODO to clear previous assignment, as following use_ok test is expected to pass use_ok 'MyWarner'; }, qr/^Deprecated! run for your lives! at \Q$file\E line $line/, "Got the warning" ); } ok(!capture { no warnings 'deprecated'; use_ok 'MyWarner' }, "No warning"); done_testing; is_capture.t100644001750001750 57214772042322 22613 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Regressionuse strict; use warnings; use Test2::Tools::Tiny; # this test is only relevant under Devel::Cover require Test::More; my $destroy = 0; sub CountDestroy::DESTROY { $destroy++ } my $obj = bless {}, 'CountDestroy'; Test::More::is($obj, $obj, 'compare object to itself using is'); undef $obj; is $destroy, 1, 'undef object destroyed after being passed to is'; done_testing; reset_outputs.t100644001750001750 142014772042322 22661 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder; use Test::More 'no_plan'; { my $tb = Test::Builder->create(); # Store the original output filehandles and change them all. my %original_outputs; open my $fh, ">", "dummy_file.tmp"; END { 1 while unlink "dummy_file.tmp"; } for my $method (qw(output failure_output todo_output)) { $original_outputs{$method} = $tb->$method(); $tb->$method($fh); is $tb->$method(), $fh; } $tb->reset_outputs; for my $method (qw(output failure_output todo_output)) { is $tb->$method(), $original_outputs{$method}, "reset_outputs() resets $method"; } } Test2-Tools-Class.t100644001750001750 71214772042322 22447 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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(); Encoding.t100644001750001750 122314772042322 22423 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::Event::Encoding'; my $CLASS = 'Test2::Event::Encoding'; like( exception { $CLASS->new() }, qr/'encoding' is a required attribute/, "Must specify the encoding" ); my $one = $CLASS->new(encoding => 'utf8'); is($one->encoding, 'utf8', "Got encoding"); is($one->summary, "Encoding set to utf8", "Got summary"); is_deeply( $one->facet_data, { about => { package => $CLASS, details => "Encoding set to utf8", eid => $one->eid, }, control => { encoding => 'utf8' }, }, "Got facet data" ); done_testing; special_names.t100644001750001750 244214772042322 22552 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; # HARNESS-NO-FORMATTER use Test2::Tools::Tiny; ######################### # # This test us here to insure that Ok renders the way we want # ######################### use Test2::API qw/test2_stack/; # Ensure the top hub is generated test2_stack->top; my $temp_hub = test2_stack->new_hub(); require Test2::Formatter::TAP; $temp_hub->format(Test2::Formatter::TAP->new); my $ok = capture { ok(1); ok(1, ""); ok(1, " "); ok(1, "A"); ok(1, "\n"); ok(1, "\nB"); ok(1, "C\n"); ok(1, "\nD\n"); ok(1, "E\n\n"); }; my $not_ok = capture { ok(0); ok(0, ""); ok(0, " "); ok(0, "A"); ok(0, "\n"); ok(0, "\nB"); ok(0, "C\n"); ok(0, "\nD\n"); ok(0, "E\n\n"); }; test2_stack->pop($temp_hub); is($ok->{STDERR}, "", "STDERR for ok is empty"); is($ok->{STDOUT}, <{STDOUT}, <plan(@_); $ctx->release; } unless (CAN_THREAD()) { plan(0, skip_all => 'System does not have threads'); exit 0; } } use threads; no Test2::IPC; use Test::More; ok(Test2::API::test2_ipc_disabled, "disabled IPC"); ok(!Test2::API::test2_ipc, "No IPC"); done_testing; disable_ipc_c.t100644001750001750 40014772042322 22457 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/test2_ipc_disable/; BEGIN { test2_ipc_disable() } use Test2::IPC::Driver::Files; ok(Test2::API::test2_ipc_disabled, "disabled IPC"); ok(!Test2::API::test2_ipc, "No IPC"); done_testing; acceptance000755001750001750 014772042322 17707 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2try_it_todo.t100644001750001750 164314772042322 22577 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/acceptanceuse strict; use warnings; use Test2::API qw/context test2_stack/; sub done_testing { my $ctx = context(); die "Test Already ended!" if $ctx->hub->ended; $ctx->hub->finalize($ctx->trace, 1); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } sub diag { my $ctx = context(); $ctx->diag( join '', @_ ); $ctx->release; } ok(1, "First"); my $filter = test2_stack->top->filter(sub { my ($hub, $event) = @_; # Turn a diag into a note return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag'; # Set todo on ok's if ($event->isa('Test2::Event::Ok')) { $event->set_todo('here be dragons'); $event->set_effective_pass(1); } return $event; }); ok(0, "Second"); diag "should be a note"; test2_stack->top->unfilter($filter); ok(1, "Third"); done_testing; try_it_skip.t100644001750001750 31714772042322 22555 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/acceptanceuse strict; use warnings; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } plan(0, skip_all => 'testing skip all'); die "Should not see this"; 1; try_it_fork.t100644001750001750 106014772042322 22564 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/acceptanceuse strict; use warnings; use Test2::Util qw/CAN_REALLY_FORK/; use Test2::IPC; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(0, skip_all => 'System cannot fork') unless CAN_REALLY_FORK(); plan(6); for (1 .. 3) { my $pid = fork; die "Failed to fork" unless defined $pid; next if $pid; ok(1, "test 1 in pid $$"); ok(1, "test 2 in pid $$"); last; } 1; try_it_plan.t100644001750001750 45214772042322 22541 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/acceptanceuse strict; use warnings; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(2); ok(1, "First"); ok(1, "Second"); 1; Action.pm100644001750001750 142014772042322 22550 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Workflow/Taskpackage Test2::Workflow::Task::Action; use strict; use warnings; our $VERSION = '1.302210'; 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 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 LineBreak.pm100644001750001750 210114772042322 22414 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Util/Tablepackage Test2::Util::Table::LineBreak; use strict; use warnings; our $VERSION = '1.302210'; 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 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 ClassicCompare.pm100644001750001750 2744314772042322 22644 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Toolspackage Test2::Tools::ClassicCompare; use strict; use warnings; our $VERSION = '1.302210'; 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 existing 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, $unexpected, "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 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 Event.pm100644001750001750 3062214772042322 22553 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Anatomypackage Test2::Manual::Anatomy::Event; use strict; use warnings; our $VERSION = '1.302210'; 1; __END__ =head1 NAME Test2::Manual::Anatomy::Event - The internals of events =head1 DESCRIPTION Events are how tools affect 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 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 ClassicCompare2.t100644001750001750 16214772042322 22646 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Toolsuse Test2::Tools::ClassicCompare; use Test2::Tools::Basic; is_deeply({},{}, "deep checking works"); done_testing; OrderedSubset.t100644001750001750 526714772042322 22767 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Compareuse 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; AuthorTesting.t100644001750001750 47314772042322 23015 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse Test2::Bundle::Extended -target => 'Test2::Require::AuthorTesting'; { local $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; is_deeply_with_threads.t100644001750001750 257114772042322 23100 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w # Test to see if is_deeply() plays well with threads. BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use strict; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; BEGIN { unless ( $ENV{AUTHOR_TESTING} ) { print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; exit 0; } } use Test::More; my $Num_Threads = 5; plan tests => $Num_Threads * 100 + 6; sub do_one_thread { my $kid = shift; my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', 'hello', 's', 'thisisalongname', '1', '2', '3', 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); my @list2 = @list; print "# kid $kid before is_deeply\n"; for my $j (1..100) { is_deeply(\@list, \@list2); } print "# kid $kid exit\n"; return 42; } my @kids = (); for my $i (1..$Num_Threads) { my $t = threads->new(\&do_one_thread, $i); print "# parent $$: continue\n"; push(@kids, $t); } for my $t (@kids) { print "# parent $$: waiting for join\n"; my $rc = $t->join(); cmp_ok( $rc, '==', 42, "threads exit status is $rc" ); } pass("End of test"); tbt_02fhrestore.t100644001750001750 226114772042322 22634 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl use Test::Builder::Tester tests => 4; use Test::More; use Symbol; # create temporary file handles that still point indirectly # to the right place my $orig_o = gensym; my $orig_t = gensym; my $orig_f = gensym; tie *$orig_o, "My::Passthru", \*STDOUT; tie *$orig_t, "My::Passthru", \*STDERR; tie *$orig_f, "My::Passthru", \*STDERR; # redirect the file handles to somewhere else for a mo use Test::Builder; my $t = Test::Builder->new(); $t->output($orig_o); $t->failure_output($orig_f); $t->todo_output($orig_t); # run a test test_out("ok 1 - tested"); ok(1,"tested"); test_test("standard test okay"); # now check that they were restored okay ok($orig_o == $t->output(), "output file reconnected"); ok($orig_t == $t->todo_output(), "todo output file reconnected"); ok($orig_f == $t->failure_output(), "failure output file reconnected"); ##################################################################### package My::Passthru; sub PRINT { my $self = shift; my $handle = $self->[0]; print $handle @_; } sub TIEHANDLE { my $class = shift; my $self = [shift()]; return bless $self, $class; } sub READ {} sub READLINE {} sub GETC {} sub FILENO {} tbt_06errormess.t100644001750001750 603114772042322 22657 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl -w use Test::More tests => 8; use Symbol; use Test::Builder; use Test::Builder::Tester; use strict; # argh! now we need to test the thing we're testing. Basically we need # to pretty much reimplement the whole code again. This is very # annoying but can't be avoided. And onward with the cut and paste # My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING # create some private file handles my $output_handle = gensym; my $error_handle = gensym; # and tie them to this package my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; # ooooh, use the test suite my $t = Test::Builder->new; # remember the testing outputs my $original_output_handle; my $original_failure_handle; my $original_todo_handle; my $original_harness_env; my $testing_num; sub start_testing { # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); $original_todo_handle = $t->todo_output(); $original_harness_env = $ENV{HARNESS_ACTIVE}; # switch out to our own handles $t->output($output_handle); $t->failure_output($error_handle); $t->todo_output($error_handle); $ENV{HARNESS_ACTIVE} = 0; # clear the expected list $out->reset(); $err->reset(); # remember that we're testing $testing_num = $t->current_test; $t->current_test(0); } # each test test is actually two tests. This is bad and wrong # but makes blood come out of my ears if I don't at least simplify # it a little this way sub my_test_test { my $text = shift; local $^W = 0; # reset the outputs $t->output($original_output_handle); $t->failure_output($original_failure_handle); $t->todo_output($original_todo_handle); $ENV{HARNESS_ACTIVE} = $original_harness_env; # reset the number of tests $t->current_test($testing_num); # check we got the same values my $got; my $wanted; # stdout $t->ok($out->check, "STDOUT $text"); # stderr $t->ok($err->check, "STDERR $text"); } #################################################################### # Meta meta tests #################################################################### # this is a quick test to check the hack that I've just implemented # actually does a cut down version of Test::Builder::Tester start_testing(); $out->expect("ok 1 - foo"); pass("foo"); my_test_test("basic meta meta test"); start_testing(); $out->expect("not ok 1 - foo"); $err->expect("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); my_test_test("basic meta meta test 2"); start_testing(); $out->expect("ok 1 - bar"); test_out("ok 1 - foo"); pass("foo"); test_test("bar"); my_test_test("meta meta test with tbt"); start_testing(); $out->expect("ok 1 - bar"); test_out("not ok 1 - foo"); test_err("# Failed test ($0 at line ".line_num(+1).")"); fail("foo"); test_test("bar"); my_test_test("meta meta test with tbt2 "); #################################################################### no_plan_at_all.t100644001750001750 132214772042322 22677 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # Test what happens when no plan is declared and done_testing() is not seen use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder; use Test::Builder::NoOutput; my $Test = Test::Builder->new; $Test->level(0); $Test->plan( tests => 1 ); my $tb = Test::Builder::NoOutput->create; { $tb->level(0); $tb->ok(1, "just a test"); $tb->ok(1, " and another"); $tb->_ending; } $Test->is_eq($tb->read, <<'END', "proper behavior when no plan is seen"); ok 1 - just a test ok 2 - and another # Tests were run but no plan was declared and done_testing() was not seen. END no_name_in_subtest.t100644001750001750 20714772042322 23157 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Test2::Tools::Tiny; ok(1, ""); tests foo => sub { ok(1, "name"); ok(1, ""); }; done_testing; 642_persistent_end.t100644001750001750 67514772042322 22736 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test::More; use strict; use warnings; use Test2::API qw{ test2_set_is_end test2_get_is_end intercept }; my %res; intercept { my $tb = Test::Builder->new; $res{before} = test2_get_is_end(); test2_set_is_end(); $res{isset} = test2_get_is_end(); $tb->reset; $res{reset} = test2_get_is_end(); }; ok(!$res{before}, "Not the end"); ok($res{isset}, "the end"); ok(!$res{reset}, "Not the end"); done_testing; 247_check_ref_bool.t100644001750001750 153414772042322 22650 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::V0; BEGIN { skip_all "Test needs 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; Exception.t100644001750001750 232214772042322 22634 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Eventuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Exception; my $exception = Test2::Event::Exception->new( trace => {frame => []}, error => "evil at lake_of_fire.t line 6\n", ); ok($exception->causes_fail, "Exception events always cause failure"); is($exception->summary, "Exception: evil at lake_of_fire.t line 6", "Got summary"); ok($exception->diagnostics, "Exception events are counted as diagnostics"); my $facet_data = $exception->facet_data; ok($facet_data->{about}, "Got common facet data"); is_deeply( $facet_data->{errors}, [{ tag => 'ERROR', fail => 1, details => "evil at lake_of_fire.t line 6\n", }], "Got error facet", ); my $hash = {an => 'error'}; my $str = "$hash"; $exception = Test2::Event::Exception->new( trace => {frame => []}, error => $hash, ); ok($exception->causes_fail, "Exception events always cause failure"); is($exception->error, $str, "Got stringified exception"); $facet_data = $exception->facet_data; ok($facet_data->{about}, "Got common facet data"); is_deeply( $facet_data->{errors}, [{ tag => 'ERROR', fail => 1, details => $str, }], "Got error facet", ); done_testing; EventFacet000755001750001750 014772042322 21315 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modulesInfo.t100644001750001750 75314772042322 22522 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Info'; my $CLASS = 'Test2::EventFacet::Info'; my $one = $CLASS->new(details => 'foo', tag => 'bar', debug => 0); is($one->details, "foo", "Got details"); is($one->tag, "bar", "Got tag"); is($one->debug, 0, "Got 'debug' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok($CLASS->is_list, "is a list"); is($CLASS->facet_key, 'info', "Got key"); done_testing; Plan.t100644001750001750 105114772042322 22531 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Plan'; my $CLASS = 'Test2::EventFacet::Plan'; my $one = $CLASS->new(details => 'foo', count => 100, skip => 1, none => 0); is($one->details, "foo", "Got details"); is($one->count, 100, "Got 'count' value"); is($one->skip, 1, "Got 'skip' value"); is($one->none, 0, "Got 'none' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'plan', "Got key"); done_testing; Meta.t100644001750001750 122414772042322 22527 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Meta'; my $CLASS = 'Test2::EventFacet::Meta'; my $one = $CLASS->new(details => 'foo', a => 1, b => 'bar', x => undef, set_details => 'xxx'); is($one->details, "foo", "Got details"); is($one->set_details, "xxx", "set_details is a regular field, not a writer"); is($one->a, 1, "Got 'a'"); is($one->b, 'bar', "Got 'b'"); is($one->x, undef, "Got 'x'"); is($one->blah, undef, "Vivified 'blah'"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'meta', "Got key"); done_testing; Interceptor.t100644001750001750 57614772042322 22622 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Hubuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Hub::Interceptor; my $one = Test2::Hub::Interceptor->new(); ok($one->isa('Test2::Hub'), "inheritance");; my $e = exception { $one->terminate(55) }; ok($e->isa('Test2::Hub::Interceptor::Terminator'), "exception type"); like($$e, 'Label not found for "last T2_SUBTEST_WRAPPER"', "Could not find label"); done_testing; Subtest_events.t100644001750001750 67114772042322 22746 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept/; my $events = intercept { my $code = sub { ok(1) }; run_subtest('blah', $code, 'buffered'); }; ok(!$events->[0]->trace->nested, "main event is not inside a subtest"); ok($events->[0]->subtest_id, "Got subtest id"); is($events->[0]->subevents->[0]->trace->hid, $events->[0]->subtest_id, "nested events are in the subtest"); done_testing; Info000755001750001750 014772042322 21043 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacetTable.pm100644001750001750 544414772042322 22577 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/EventFacet/Infopackage Test2::EventFacet::Info::Table; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/confess/; use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string}; sub init { my $self = shift; confess "Table may not be empty" unless ref($self->{+ROWS}) eq 'ARRAY' && @{$self->{+ROWS}}; $self->{+AS_STRING} ||= '
'; } sub as_hash { my $out = +{%{$_[0]}}; delete $out->{as_string}; $out } sub info_args { my $self = shift; my $hash = $self->as_hash; my $desc = $self->as_string; return (table => $hash, details => $desc); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Info::Table - Intermediary representation of a table. =head1 DESCRIPTION Intermediary representation of a table for use in specialized L methods which generate L facets. =head1 SYNOPSIS use Test2::EventFacet::Info::Table; use Test2::API qw/context/; sub my_tool { my $ctx = context(); ... $ctx->fail( $name, "failure diag message", Test2::EventFacet::Info::Table->new( # Required rows => [['a', 'b'], ['c', 'd'], ...], # Strongly Recommended as_string => "... string to print when table cannot be rendered ...", # Optional header => ['col1', 'col2'], collapse => $bool, no_collapse => ['col1', ...], ), ); ... $ctx->release; } my_tool(); =head1 ATTRIBUTES =over 4 =item $header_aref = $t->header() =item $rows_aref = $t->rows() =item $bool = $t->collapse() =item $aref = $t->no_collapse() The above are all directly tied to the table hashref structure described in L. =item $str = $t->as_string() This returns the string form of the table if it was set, otherwise it returns the string C<< "
" >>. =item $href = $t->as_hash() This returns the data structure used for tables by L. =item %args = $t->info_args() This returns the arguments that should be used to construct the proper L structure. return (table => $t->as_hash(), details => $t->as_string()); =back =head1 SOURCE The source code repository for Test2 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 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 OrderedSubset.pm100644001750001750 661014772042322 22765 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Comparepackage Test2::Compare::OrderedSubset; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '1.302210'; 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 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 AuthorTesting.pm100644001750001750 231414772042322 23036 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::AuthorTesting; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; 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 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 ReleaseTesting.t100644001750001750 50014772042322 23122 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse Test2::Bundle::Extended -target => 'Test2::Require::ReleaseTesting'; { local $ENV{RELEASE_TESTING} = 0; is($CLASS->skip(), 'Release test, set the $RELEASE_TESTING environment variable to run it', "will skip"); $ENV{RELEASE_TESTING} = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; Workflow-Acceptance.t100644001750001750 7466714772042322 23135 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse strict; use warnings; use Test2::Require::AuthorTesting; 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; tbt_09do_script.pl100644001750001750 32714772042322 22761 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Tester#!/usr/bin/perl use strict; use warnings; isnt($0, __FILE__, 'code is not executing directly'); test_out("not ok 1 - one"); test_fail(+1); ok(0,"one"); test_test('test_fail caught fail message inside a do'); 1; Error.t100644001750001750 76414772042322 22722 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Error'; my $CLASS = 'Test2::EventFacet::Error'; my $one = $CLASS->new(details => 'foo', tag => 'uhg', fail => 1); is($one->details, "foo", "Got details"); is($one->tag, 'uhg', "Got 'tag' value"); is($one->fail, 1, "Got 'fail' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok($CLASS->is_list, "is a list"); is($CLASS->facet_key, 'errors', "Got key"); done_testing; About.t100644001750001750 101114772042322 22705 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::About'; my $CLASS = 'Test2::EventFacet::About'; my $one = $CLASS->new(details => 'foo', package => 'bar', no_display => 0); is($one->details, "foo", "Got details"); is($one->package, "bar", "Got package"); is($one->no_display, 0, "Got no_display value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "Not a list"); is($CLASS->facet_key, 'about', "Got key"); done_testing; Trace.t100644001750001750 232714772042322 22704 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use Test2::EventFacet::Trace; my $CLASS = 'Test2::EventFacet::Trace'; like( exception { $CLASS->new() }, qr/The 'frame' attribute is required/, "got error" ); my $one = $CLASS->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); is($one->package, 'Foo::Bar', "Got package"); is($one->file, 'foo.t', "Got file"); is($one->line, 5, "Got line"); is($one->subname, 'Foo::Bar::foo', "got subname"); is($one->debug, "at foo.t line 5", "got trace"); $one->set_detail("yo momma"); is($one->debug, "yo momma", "got detail for trace"); $one->set_detail(undef); is( exception { $one->throw('I died') }, "I died at foo.t line 5.\n", "got exception" ); is_deeply( warnings { $one->alert('I cried') }, [ "I cried at foo.t line 5.\n" ], "alter() warns" ); my $snap = $one->snapshot; is_deeply($snap, $one, "identical"); ok($snap != $one, "Not the same instance"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'trace', "Got key"); done_testing; Driver000755001750001750 014772042322 21137 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/IPCFiles.t100644001750001750 4127414772042322 22556 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/IPC/Driveruse Test2::Tools::Tiny; use Test2::Util qw/get_tid USE_THREADS try ipc_separator/; use File::Temp qw/tempfile/; use File::Spec; use List::Util qw/shuffle/; use strict; use warnings; if ("$]" < 5.008) { print "1..0 # SKIP Test cannot run on perls below 5.8.0\n"; exit 0; } sub simple_capture(&) { my $code = shift; my ($err, $out) = ("", ""); my ($ok, $e); { local *STDOUT; local *STDERR; ($ok, $e) = try { open(STDOUT, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open(STDERR, '>', \$err) or die "Failed to open a temporary STDERR: $!"; $code->(); }; } die $e unless $ok; return { STDOUT => $out, STDERR => $err, }; } require Test2::IPC::Driver::Files; ok(my $ipc = Test2::IPC::Driver::Files->new, "Created an IPC instance"); ok($ipc->isa('Test2::IPC::Driver::Files'), "Correct type"); ok($ipc->isa('Test2::IPC::Driver'), "inheritance"); ok(-d $ipc->tempdir, "created temp dir"); is($ipc->pid, $$, "stored pid"); is($ipc->tid, get_tid(), "stored the tid"); my $hid = join ipc_separator, qw'12345 1 1 1'; $ipc->add_hub($hid); my $hubfile = File::Spec->catfile($ipc->tempdir, "HUB" . ipc_separator . $hid); ok(-f $hubfile, "wrote hub file"); if(ok(open(my $fh, '<', $hubfile), "opened hub file")) { my @lines = <$fh>; close($fh); is_deeply( \@lines, [ "$$\n", get_tid() . "\n" ], "Wrote pid and tid to hub file" ); } { package Foo; use base 'Test2::Event'; } $ipc->send($hid, bless({ foo => 1 }, 'Foo')); $ipc->send($hid, bless({ bar => 1 }, 'Foo')); my $sep = ipc_separator; opendir(my $dh, $ipc->tempdir) || die "Could not open tempdir: !?"; my @files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB${sep}$hid/ } readdir($dh); closedir($dh); is(@files, 2, "2 files added to the IPC directory"); my @events = $ipc->cull($hid); is_deeply( \@events, [{ foo => 1 }, { bar => 1 }], "Culled both events" ); opendir($dh, $ipc->tempdir) || die "Could not open tempdir: !?"; @files = grep { $_ !~ m/^\.+$/ && $_ !~ m/^HUB$sep$hid/ } readdir($dh); closedir($dh); is(@files, 0, "All files collected"); $ipc->drop_hub($hid); ok(!-f $ipc->tempdir . '/' . $hid, "removed hub file"); $ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL'); my @got = $ipc->cull($hid); ok(@got == 0, "did not get our own global event"); my $tmpdir = $ipc->tempdir; ok(-d $tmpdir, "still have temp dir"); $ipc = undef; ok(!-d $tmpdir, "cleaned up temp dir"); { my $ipc = Test2::IPC::Driver::Files->new(); my $tmpdir = $ipc->tempdir; my $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_thread_clone->set_tid(100); $ipc_thread_clone = undef; ok(-d $tmpdir, "Directory not removed (different thread)"); my $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_fork_clone->set_pid($$ + 10); $ipc_fork_clone = undef; ok(-d $tmpdir, "Directory not removed (different proc)"); $ipc_thread_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_thread_clone->set_tid(undef); $ipc_thread_clone = undef; ok(-d $tmpdir, "Directory not removed (no thread)"); $ipc_fork_clone = bless {%$ipc}, 'Test2::IPC::Driver::Files'; $ipc_fork_clone->set_pid(undef); $ipc_fork_clone = undef; ok(-d $tmpdir, "Directory not removed (no proc)"); $ipc = undef; ok(!-d $tmpdir, "Directory removed"); } { no warnings qw/once redefine/; local *Test2::IPC::Driver::Files::driver_abort = sub {}; local *Test2::IPC::Driver::Files::abort = sub { my $self = shift; local $self->{no_fatal} = 1; local $self->{no_bail} = 1; $self->Test2::IPC::Driver::abort(@_); die 255; }; my $tmpdir; my @lines; my $file = __FILE__; my $out = simple_capture { local $ENV{T2_KEEP_TEMPDIR} = 1; my $ipc = Test2::IPC::Driver::Files->new(); $tmpdir = $ipc->tempdir; $ipc->add_hub($hid); eval { $ipc->add_hub($hid) }; push @lines => __LINE__; $ipc->send($hid, bless({ foo => 1 }, 'Foo')); $ipc->cull($hid); $ipc->drop_hub($hid); eval { $ipc->drop_hub($hid) }; push @lines => __LINE__; # Make sure having a hub file sitting around does not throw things off # in T2_KEEP_TEMPDIR $ipc->add_hub($hid); $ipc = undef; 1; }; my $cleanup = sub { if (opendir(my $d, $tmpdir)) { for my $f (readdir($d)) { next if $f =~ m/^\.+$/; my $file = File::Spec->catfile($tmpdir, $f); next unless -f $file; 1 while unlink $file; } closedir($d); rmdir($tmpdir) or warn "Could not remove temp dir '$tmpdir': $!"; } }; $cleanup->(); like($out->{STDERR}, qr/IPC Temp Dir: \Q$tmpdir\E/m, "Got temp dir path"); like($out->{STDERR}, qr/^# Not removing temp dir: \Q$tmpdir\E$/m, "Notice about not closing tempdir"); like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '$hid' already exists/m, "Got message for duplicate hub"); like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '$hid' does not exist/m, "Cannot remove hub twice"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); my $e = eval { $ipc->send($hid, bless({glob => \*ok, trace => $trace}, 'Foo')); 1 }; print STDERR $@ unless $e || $@ =~ m/^255/; $ipc->drop_hub($hid); }; like($out->{STDERR}, qr/IPC Fatal Error:/, "Got fatal error"); like($out->{STDERR}, qr/There was an error writing an event/, "Explanation"); like($out->{STDERR}, qr/Destination: $hid/, "Got dest"); like($out->{STDERR}, qr/Origin PID:\s+$$/, "Got pid"); like($out->{STDERR}, qr/Error: Can't store GLOB items/, "Got cause"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); local $@; eval { $ipc->send($hid, bless({ foo => 1 }, 'Foo')) }; print STDERR $@ unless $@ =~ m/^255/; $ipc = undef; }; like($out->{STDERR}, qr/IPC Fatal Error: hub '$hid' is not available, failed to send event!/, "Cannot send to missing hub"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); $tmpdir = $ipc->tempdir; $ipc->add_hub($hid); $ipc->send($hid, bless({ foo => 1 }, 'Foo')); local $@; eval { $ipc->drop_hub($hid) }; print STDERR $@ unless $@ =~ m/^255/; }; $cleanup->(); like($out->{STDERR}, qr/IPC Fatal Error: Not all files from hub '$hid' have been collected/, "Leftover files"); like($out->{STDERR}, qr/IPC Fatal Error: Leftover files in the directory \(.*\.ready\)/, "What file"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); eval { $ipc->send($hid, { foo => 1 }) }; print STDERR $@ unless $@ =~ m/^255/; eval { $ipc->send($hid, bless({ foo => 1 }, 'xxx')) }; print STDERR $@ unless $@ =~ m/^255/; }; like($out->{STDERR}, qr/IPC Fatal Error: 'HASH\(.*\)' is not a blessed object/, "Cannot send unblessed objects"); like($out->{STDERR}, qr/IPC Fatal Error: 'xxx=HASH\(.*\)' is not an event object!/, "Cannot send non-event objects"); $ipc = Test2::IPC::Driver::Files->new(); my ($fh, $fn) = tempfile(); print $fh "\n"; close($fh); Storable::store({}, $fn); $out = simple_capture { eval { $ipc->read_event_file($fn) } }; like( $out->{STDERR}, qr/IPC Fatal Error: Got an unblessed object: 'HASH\(.*\)'/, "Events must actually be events (must be blessed)" ); Storable::store(bless({}, 'Test2::Event::FakeEvent'), $fn); $out = simple_capture { eval { $ipc->read_event_file($fn) } }; like( $out->{STDERR}, qr{IPC Fatal Error: Event has unknown type \(Test2::Event::FakeEvent\), tried to load 'Test2/Event/FakeEvent\.pm' but failed: Can't locate Test2/Event/FakeEvent\.pm}, "Events must actually be events (not a real module)" ); Storable::store(bless({}, 'Test2::API'), $fn); $out = simple_capture { eval { $ipc->read_event_file($fn) } }; like( $out->{STDERR}, qr{'Test2::API=HASH\(.*\)' is not a 'Test2::Event' object}, "Events must actually be events (not an event type)" ); Storable::store(bless({}, 'Foo'), $fn); $out = simple_capture { local @INC; push @INC => ('t/lib', 'lib'); eval { $ipc->read_event_file($fn) }; }; ok(!$out->{STDERR}, "no problem", $out->{STDERR}); ok(!$out->{STDOUT}, "no problem", $out->{STDOUT}); unlink($fn); } { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); $ipc->send($hid, bless({global => 1}, 'Foo'), 'GLOBAL'); $ipc->set_globals({}); my @events = $ipc->cull($hid); is_deeply( \@events, [ {global => 1} ], "Got global event" ); @events = $ipc->cull($hid); ok(!@events, "Did not grab it again"); $ipc->set_globals({}); @events = $ipc->cull($hid); is_deeply( \@events, [ {global => 1} ], "Still there" ); $ipc->drop_hub($hid); $ipc = undef; } { my @list = shuffle ( {global => 0, pid => 2, tid => 1, eid => 1}, {global => 0, pid => 2, tid => 1, eid => 2}, {global => 0, pid => 2, tid => 1, eid => 3}, {global => 1, pid => 1, tid => 1, eid => 1}, {global => 1, pid => 12, tid => 1, eid => 3}, {global => 1, pid => 11, tid => 1, eid => 2}, {global => 0, pid => 2, tid => 3, eid => 1}, {global => 0, pid => 2, tid => 3, eid => 10}, {global => 0, pid => 2, tid => 3, eid => 100}, {global => 0, pid => 5, tid => 3, eid => 2}, {global => 0, pid => 5, tid => 3, eid => 20}, {global => 0, pid => 5, tid => 3, eid => 200}, ); my @sorted; { package Test2::IPC::Driver::Files; @sorted = sort cmp_events @list; } is_deeply( \@sorted, [ {global => 1, pid => 1, tid => 1, eid => 1}, {global => 1, pid => 11, tid => 1, eid => 2}, {global => 1, pid => 12, tid => 1, eid => 3}, {global => 0, pid => 2, tid => 1, eid => 1}, {global => 0, pid => 2, tid => 1, eid => 2}, {global => 0, pid => 2, tid => 1, eid => 3}, {global => 0, pid => 2, tid => 3, eid => 1}, {global => 0, pid => 2, tid => 3, eid => 10}, {global => 0, pid => 2, tid => 3, eid => 100}, {global => 0, pid => 5, tid => 3, eid => 2}, {global => 0, pid => 5, tid => 3, eid => 20}, {global => 0, pid => 5, tid => 3, eid => 200}, ], "Sort by global, pid, tid and then eid" ); } { my $ipc = 'Test2::IPC::Driver::Files'; is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo.ready.complete'), { ready => !!1, complete => !!1, global => 1, type => "Event::Type::Foo", hid => "GLOBAL", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo', }, "Parsed global complete" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo.ready'), { ready => !!1, complete => !!0, global => 1, type => "Event::Type::Foo", hid => "GLOBAL", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo', }, "Parsed global ready" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo'), { ready => !!0, complete => !!0, global => 1, type => "Event::Type::Foo", hid => "GLOBAL", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo', }, "Parsed global not ready" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'1 1 1 1 123 456 789 Event Type Foo.ready.complete'), { ready => !!1, complete => !!1, global => 0, type => "Event::Type::Foo", hid => "1${sep}1${sep}1${sep}1", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'1 1 1 1 123 456 789 Event Type Foo', }, "Parsed event complete" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'1 2 3 4 123 456 789 Event Type Foo.ready'), { ready => !!1, complete => !!0, global => 0, type => "Event::Type::Foo", hid => "1${sep}2${sep}3${sep}4", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'1 2 3 4 123 456 789 Event Type Foo', }, "Parsed event ready" ); is_deeply( $ipc->parse_event_filename(join ipc_separator, qw'3 2 11 12 123 456 789 Event'), { ready => !!0, complete => !!0, global => 0, type => "Event", hid => "3${sep}2${sep}11${sep}12", pid => "123", tid => "456", eid => "789", file => join ipc_separator, qw'3 2 11 12 123 456 789 Event', }, "Parsed event not ready" ); } { my $ipc = Test2::IPC::Driver::Files->new(); my $hid = join ipc_separator, qw"1 1 1 1"; is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready.complete") ? 1 : 0, 0, "Do not read complete global" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready") ? 1 : 0, 1, "Should read ready global the first time" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo.ready") ? 1 : 0, 0, "Should not read ready global again" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"GLOBAL 123 456 789 Event Type Foo") ? 1 : 0, 0, "Should not read un-ready global" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready.complete") ? 1 : 0, 0, "Do not read complete our hid" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready") ? 1 : 0, 1, "Should read ready our hid" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready") ? 1 : 0, 1, "Should read ready our hid (again, no duplicate checking)" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo") ? 1 : 0, 0, "Should not read un-ready our hid" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo.ready.complete") ? 1 : 0, 0, "Not ours - complete" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo.ready") ? 1 : 0, 0, "Not ours - ready" ); is_deeply( $ipc->should_read_event($hid, join ipc_separator, qw"1 2 3 123 456 789 Event Type Foo") ? 1 : 0, 0, "Not ours - unready" ); my @got = $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo"); ok(!@got, "return empty list for false"); @got = $ipc->should_read_event($hid, join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready"); is(@got, 1, "got 1 item on true"); like(delete $got[0]->{full_path}, qr{^.+\Q$hid\E${sep}123${sep}456${sep}789${sep}Event${sep}Type${sep}Foo\.ready$}, "Got full path"); is_deeply( $got[0], $ipc->parse_event_filename(join ipc_separator, $hid, qw"123 456 789 Event Type Foo.ready"), "Apart from full_path we get entire parsed filename" ); $ipc = undef; } done_testing; subtest_bailout.t100644001750001750 223614772042322 23160 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse Test2::Tools::Tiny; use strict; use warnings; use Test2::API qw/context run_subtest intercept/; sub subtest { my ($name, $code) = @_; my $ctx = context(); my $pass = run_subtest($name, $code, {buffered => 1}, @_); $ctx->release; return $pass; } sub bail { my $ctx = context(); $ctx->bail(@_); $ctx->release; } my $events = intercept { subtest outer => sub { subtest inner => sub { bail("bye!"); }; }; }; ok($events->[0]->isa('Test2::Event::Subtest'), "Got a subtest event when bail-out issued in a buffered subtest"); ok($events->[-1]->isa('Test2::Event::Bail'), "Bail-Out propagated"); ok(!$events->[-1]->facet_data->{trace}->{buffered}, "Final Bail-Out is not buffered"); ok($events->[0]->subevents->[-2]->isa('Test2::Event::Bail'), "Got bail out inside outer subtest"); ok($events->[0]->subevents->[-2]->facet_data->{trace}->{buffered}, "Bail-Out is buffered"); ok($events->[0]->subevents->[0]->subevents->[-2]->isa('Test2::Event::Bail'), "Got bail out inside inner subtest"); ok($events->[0]->subevents->[0]->subevents->[-2]->facet_data->{trace}->{buffered}, "Bail-Out is buffered"); done_testing; trace_signature.t100644001750001750 274314772042322 23132 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept context/; use Test2::Util qw/get_tid/; my $line; my $events = intercept { $line = __LINE__ + 1; ok(1, "pass"); sub { my $ctx = context; $ctx->pass; $ctx->pass; $ctx->release; }->(); }; my $sigpass = $events->[0]->trace->signature; my $sigfail = $events->[1]->trace->signature; ok($sigpass ne $sigfail, "Each tool got a new signature"); is($events->[$_]->trace->signature, $sigfail, "Diags share failed ok's signature") for 2 .. $#$events; like($sigpass, qr/$$~${ \get_tid() }~\d+~\d+:$$:\Q${ \get_tid() }:${ \__FILE__ }:$line\E$/, "signature is sane"); my $trace = Test2::EventFacet::Trace->new(frame => ['main', 'foo.t', 42, 'xxx']); delete $trace->{cid}; is($trace->signature, undef, "No signature without a cid"); is($events->[0]->related($events->[1]), 0, "event 0 is not related to event 1"); is($events->[1]->related($events->[2]), 1, "event 1 is related to event 2"); my $e = Test2::Event::Ok->new(pass => 1); is($e->related($events->[0]), undef, "Cannot check relation, invalid trace"); $e = Test2::Event::Ok->new(pass => 1, trace => Test2::EventFacet::Trace->new(frame => ['', '', '', ''])); is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); $e = Test2::Event::Ok->new(pass => 1, trace => Test2::EventFacet::Trace->new(frame => [])); is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); done_testing; Formatter.pm100644001750001750 20714772042322 23173 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/AsyncSubtestpackage Test2::AsyncSubtest::Formatter; use strict; use warnings; our $VERSION = '1.302210'; die "Should not load this anymore"; 1; ReleaseTesting.pm100644001750001750 232414772042322 23155 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::ReleaseTesting; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; sub skip { my $class = shift; return undef if $ENV{'RELEASE_TESTING'}; return 'Release test, set the $RELEASE_TESTING environment variable to run it'; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Require::ReleaseTesting - Only run a test when the RELEASE_TESTING environment variable is set. =head1 DESCRIPTION It is common practice to write tests that are only run when the RELEASE_TESTING environment variable is set. This module automates the (admittedly trivial) work of creating such a test. =head1 SYNOPSIS use Test2::Require::ReleaseTesting; ... 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 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 Context.pm100644001750001750 725114772042322 23100 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Anatomypackage Test2::Manual::Anatomy::Context; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Tooling000755001750001750 014772042322 20754 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/ManualTesting.pm100644001750001750 1063214772042322 23111 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Toolingpackage Test2::Manual::Tooling::Testing; use strict; use warnings; our $VERSION = '1.302210'; 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 affect 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 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 Subtest.pm100644001750001750 771214772042322 23112 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Toolingpackage Test2::Manual::Tooling::Subtest; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Nesting.pm100644001750001750 706114772042322 23065 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Toolingpackage Test2::Manual::Tooling::Nesting; use strict; use warnings; our $VERSION = '1.302210'; 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 its 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 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 ExtendedTesting.t100644001750001750 50514772042323 23310 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse Test2::Bundle::Extended -target => 'Test2::Require::ExtendedTesting'; { local $ENV{EXTENDED_TESTING} = 0; is($CLASS->skip(), 'Extended test, set the $EXTENDED_TESTING environment variable to run it', "will skip"); $ENV{EXTENDED_TESTING} = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; Workflow-Acceptance3.t100644001750001750 25014772042323 23132 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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; Workflow-Acceptance4.t100644001750001750 37114772042323 23137 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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; Workflow-Acceptance5.t100644001750001750 170614772042323 23163 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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 (lexical)"); }; 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 (overridden)") }; 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; Workflow-Acceptance2.t100644001750001750 42414772042323 23134 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/acceptanceuse 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; 789-read-only.t100644001750001750 124014772042323 22706 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Regressionuse Test::More; use strict; use warnings; # HARNESS-NO-STREAM # See https://github.com/Test-More/test-more/issues/789 BEGIN { plan skip_all => 'AUTHOR_TESTING not enabled' unless $ENV{AUTHOR_TESTING}; plan skip_all => "This test requires Test::Class" unless eval { require Test::Class; 1 }; plan skip_all => "This test requires Test::Script" unless eval { require Test::Script; 1 }; } package Test; use base 'Test::Class'; use Test::More; use Test::Script; sub a_compilation_test : Test(startup => 1) { script_compiles(__FILE__); } sub test : Test(1) { ok(1); } package main; use Test::Class; Test::Class->runtests; 757-reset_in_subtest.t100644001750001750 44114772042323 23206 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Test::More; subtest 'subtest' => sub { Test::Builder->new->reset; ok 1; }; subtest 'subtest' => sub { Test::Builder->new->reset; subtest 'subtest' => sub { Test::Builder->new->reset; ok 1; }; ok 1; }; done_testing; 285-wrap-nonexisting.t100644001750001750 63214772042323 23137 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::V0; { package Foo; sub foo { 1 } package Bar; push @Bar::ISA => 'Foo'; sub bar { 1 } } like( dies { my $x = mock Bar => (around => [foo => sub { }]) }, qr/Attempt to modify a sub that does not exist 'Bar::foo' \(Mock operates on packages, not classes, are you looking for a symbol in a parent class\?\)/, "Cannot wrap symbol that does not exist" ); done_testing; 684-nested_todo_diag.t100644001750001750 101014772042323 23130 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test::More; use strict; use warnings; use Test2::API qw/intercept/; my @events; intercept { local $TODO = "broken"; Test2::API::test2_stack->top->listen(sub { push @events => $_[1] }, inherit => 1); subtest foo => sub { subtest bar => sub { ok(0, 'oops'); }; }; }; my ($event) = grep { $_->trace->line == 16 && ref($_) eq 'Test::Builder::TodoDiag'} @events; ok($event, "nested todo diag on line 16 was changed to TodoDiag (STDOUT instead of STDERR)"); done_testing; TAP000755001750001750 014772042323 20777 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventVersion.t100644001750001750 116114772042323 22750 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Event/TAPuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::Event::TAP::Version'; my $CLASS = 'Test2::Event::TAP::Version'; like( exception { $CLASS->new() }, qr/'version' is a required attribute/, "Must specify the version" ); my $one = $CLASS->new(version => 13); is($one->version, 13, "Got version"); is($one->summary, "TAP version 13", "Got summary"); is_deeply( $one->facet_data, { about => { package => $CLASS, details => "TAP version 13", eid => $one->eid}, info => [{tag => 'INFO', debug => 0, details => "TAP version 13"}], }, "Got facet data" ); done_testing; ExternalMeta.t100644001750001750 347414772042323 23135 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Utiluse strict; use warnings; use Test2::Tools::Tiny; { package Foo::Bar; use Test2::Util::ExternalMeta; use Test2::Util::HashBase qw/foo bar/; } ok(Foo::Bar->can($_), "Imported '$_'") for qw/meta get_meta set_meta delete_meta/; my $one = Foo::Bar->new(foo => 1, bar => 2); ok($one->isa('Foo::Bar'), "Got instance"); is_deeply($one, {foo => 1, bar => 2}, "nothing fishy.. yet"); is($one->get_meta('foo'), undef, "no meta-data for foo"); is($one->get_meta('bar'), undef, "no meta-data for bar"); is($one->get_meta('baz'), undef, "no meta-data for baz"); is($one->meta('foo'), undef, "no meta-data for foo"); is($one->meta('bar'), undef, "no meta-data for bar"); is($one->meta('baz'), undef, "no meta-data for baz"); is_deeply($one, {foo => 1, bar => 2}, "Still have not modified instance"); $one->set_meta('foo' => 123); is($one->foo, 1, "did not change attribute"); is($one->meta('foo'), 123, "get meta-data for foo"); is($one->get_meta('foo'), 123, "get meta-data for foo again"); $one->meta('foo', 345); is($one->foo, 1, "did not change attribute"); is($one->meta('foo', 678), 123, "did not alter already set meta-attribute"); is($one->get_meta('foo'), 123, "still did not alter already set meta-attribute"); is($one->meta('bar', 789), 789, "used default for bar"); is($one->bar, 2, "did not change attribute"); is_deeply( $one, { foo => 1, bar => 2, Test2::Util::ExternalMeta::META_KEY() => { foo => 123, bar => 789, }, }, "Stored meta-data" ); is($one->delete_meta('foo'), 123, "got old value on delete"); is($one->meta('foo'), undef, "no more value"); is_deeply( $one, { foo => 1, bar => 2, Test2::Util::ExternalMeta::META_KEY() => { bar => 789, }, }, "Deleted the meta key" ); done_testing; Assert.t100644001750001750 100214772042323 23075 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Assert'; my $CLASS = 'Test2::EventFacet::Assert'; my $one = $CLASS->new(details => 'foo', pass => 1, no_debug => 1); is($one->details, "foo", "Got details"); is($one->pass, 1, "Got 'pass' value"); is($one->no_debug, 1, "Got 'no_debug' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'assert', "Got key"); done_testing; Parent.t100644001750001750 111614772042323 23073 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Parent'; my $CLASS = 'Test2::EventFacet::Parent'; my $one = $CLASS->new(details => 'foo', hid => 'abc', children => [], buffered => 1); is($one->details, "foo", "Got details"); is($one->hid, 'abc', "Got 'hid' value"); is($one->buffered, 1, "Got 'buffered' value"); is_deeply($one->children, [], "Got 'children' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'parent', "Got key"); done_testing; ipc_wait_timeout.t100644001750001750 445714772042323 23325 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; # The things done in this test can trigger a buggy return value on some # platforms. This prevents that. The harness should catch actual failures. If # no harness is active then we will NOT sanitize the exit value, false fails # are better than false passes. END { $? = 0 if $ENV{HARNESS_ACTIVE} } # Some platforms throw a sigpipe in this test, we can ignore it. BEGIN { $SIG{PIPE} = 'IGNORE' } BEGIN { local ($@, $?, $!); eval { require threads } } use Test2::Tools::Tiny; use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK/; use Test2::IPC; use Test2::API qw/test2_ipc_set_timeout test2_ipc_get_timeout/; my $plan = 2; $plan += 2 if CAN_REALLY_FORK; $plan += 2 if CAN_THREAD && threads->can('is_joinable'); plan $plan; is(test2_ipc_get_timeout(), 30, "got default timeout"); test2_ipc_set_timeout(10); is(test2_ipc_get_timeout(), 10, "hanged the timeout"); if (CAN_REALLY_FORK) { note "Testing process waiting"; my ($ppiper, $ppipew); pipe($ppiper, $ppipew) or die "Could not create pipe for fork"; my $proc = fork(); die "Could not fork!" unless defined $proc; unless ($proc) { local $SIG{ALRM} = sub { die "PROCESS TIMEOUT" }; alarm 15; my $ignore = <$ppiper>; exit 0; } my $exit; my $warnings = warnings { $exit = Test2::API::Instance::_ipc_wait(1); }; is($exit, 255, "Exited 255"); like($warnings->[0], qr/Timeout waiting on child processes/, "Warned about timeout"); print $ppipew "end\n"; close($ppiper); close($ppipew); } if (CAN_THREAD) { note "Testing thread waiting"; my ($tpiper, $tpipew); pipe($tpiper, $tpipew) or die "Could not create pipe for threads"; my $thread = threads->create( sub { local $SIG{ALRM} = sub { die "THREAD TIMEOUT" }; alarm 15; my $ignore = <$tpiper>; } ); if ($thread->can('is_joinable')) { my $exit; my $warnings = warnings { $exit = Test2::API::Instance::_ipc_wait(1); }; is($exit, 255, "Exited 255"); like($warnings->[0], qr/Timeout waiting on child thread/, "Warned about timeout"); } else { note "threads.pm is too old for a thread joining timeout :-("; } print $tpipew "end\n"; close($tpiper); close($tpipew); } Subtest_callback.t100644001750001750 161214772042323 23213 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept/; my $step = 0; my @callback_calls = (); Test2::API::test2_add_callback_pre_subtest( sub { is( $step, 0, 'pre-subtest callbacks should be invoked before the subtest', ); ++$step; push @callback_calls, [@_]; }, ); run_subtest( (my $subtest_name='some subtest'), (my $subtest_code=sub { is( $step, 1, 'subtest should be run after the pre-subtest callbacks', ); ++$step; }), undef, (my @subtest_args = (1,2,3)), ); is_deeply( \@callback_calls, [[$subtest_name,$subtest_code,@subtest_args]], 'pre-subtest callbacks should be invoked with the expected arguments', ); is( $step, 2, 'the subtest should be run', ); done_testing; try_it_threads.t100644001750001750 110314772042323 23254 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/acceptanceuse strict; use warnings; use Test2::Util qw/CAN_THREAD/; use Test2::IPC; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(0, skip_all => 'System does not have threads') unless CAN_THREAD(); plan(6); require threads; threads->import; for (1 .. 3) { threads->create(sub { ok(1, "test 1 in thread " . threads->tid()); ok(1, "test 2 in thread " . threads->tid()); }); } 1; try_it_no_plan.t100644001750001750 46514772042323 23242 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/acceptanceuse strict; use warnings; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(0, 'no_plan'); ok(1, "First"); ok(1, "Second"); 1; InterceptResult000755001750001750 014772042323 21672 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/APIHub.pm100644001750001750 170414772042323 23110 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/API/InterceptResultpackage Test2::API::InterceptResult::Hub; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; sub init { my $self = shift; $self->SUPER::init(); $self->{+NESTED} = 0; } sub inherit { my $self = shift; $self->{+NESTED} = 0; } sub terminate { } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult::Hub - Hub used by InterceptResult. =head1 SOURCE The source code repository for Test2 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 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 ExtendedTesting.pm100644001750001750 233414772042323 23337 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::ExtendedTesting; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; sub skip { my $class = shift; return undef if $ENV{'EXTENDED_TESTING'}; return 'Extended test, set the $EXTENDED_TESTING environment variable to run it'; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Require::ExtendedTesting - Only run a test when the EXTENDED_TESTING environment variable is set. =head1 DESCRIPTION It is common practice to write tests that are only run when the EXTENDED_TESTING environment variable is set. This module automates the (admittedly trivial) work of creating such a test. =head1 SYNOPSIS use Test2::Require::ExtendedTesting; ... 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 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 EndToEnd.pm100644001750001750 2547314772042323 23143 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Anatomypackage Test2::Manual::Anatomy::EndToEnd; use strict; use warnings; our $VERSION = '1.302210'; 1; __END__ =head1 NAME Test2::Manual::Anatomy::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 affect anything else. This is done in case something inside the context construction accidentally changed these vars. =item The context is returned. You have a shiny 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 affects test count then the count will be incremented. If the event causes failure then the failure count will be incremented. There are a few other ways the global state can be affected 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 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 Planning.pm100644001750001750 412214772042323 23222 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Testingpackage Test2::Manual::Testing::Planning; use strict; use warnings; our $VERSION = '1.302210'; 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 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 AutomatedTesting.t100644001750001750 51214772042323 23471 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse Test2::Bundle::Extended -target => 'Test2::Require::AutomatedTesting'; { local $ENV{AUTOMATED_TESTING} = 0; is($CLASS->skip(), 'Automated test, set the $AUTOMATED_TESTING environment variable to run it', "will skip"); $ENV{AUTOMATED_TESTING} = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; 862-intercept_tb_todo.t100644001750001750 266414772042323 23362 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Test::More; use Test2::API qw/intercept/; my $events; { local $TODO = "main-outer-todo"; package Foo; our $TODO; local $TODO = "foo-outer-todo"; $events = main::intercept(sub { main::ok(1, "assertion 1"); { local $main::TODO = "main-inner-todo"; main::ok(1, "assertion 2"); } { local $Foo::TODO = "foo-inner-todo"; main::ok(1, "assertion 3"); } main::ok(1, "assertion 4"); }); # Cannot use intercept, so make a failing test, the overall test file # should still pass because this is todo. If this is not todo we know we # broke something by the test failing overall. main::ok(0, "Verifying todo, this should be a failed todo test"); } @$events = grep { $_->facet_data->{assert} } @$events; ok(!$events->[0]->facet_data->{amnesty}, "No amnesty for the first event, \$TODO was cleaned"); is_deeply( $events->[1]->facet_data->{amnesty}, [{ tag => 'TODO', details => 'main-inner-todo', }], "The second event had the expected amnesty applied", ); is_deeply( $events->[2]->facet_data->{amnesty}, [{ tag => 'TODO', details => 'foo-inner-todo', }], "The third event had the expected amnesty applied", ); ok(!$events->[3]->facet_data->{amnesty}, "No amnesty for the fourth event, \$TODO was cleaned"); done_testing; builder_does_not_init.t100644001750001750 55214772042323 23653 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Carp qw/confess/; use Test2::API::Instance; BEGIN { no warnings 'redefine'; local *Test2::API::Instance::_finalize = sub { confess "_finalize called\n" }; local *Test2::API::Instance::load = sub { confess "load called\n" }; require Test::Builder; } use Test2::Tools::Tiny; ok(1, "Did not die"); done_testing(); Facets2Legacy.t100644001750001750 1056214772042323 23174 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Utiluse strict; use warnings; use Test2::Tools::Tiny; use Test2::Util::Facets2Legacy ':ALL'; my $CLASS; BEGIN { $CLASS = 'Test2::Util::Facets2Legacy'; # This private function is not exported, but we want to test it anyway *_get_facet_data = $CLASS->can('_get_facet_data'); } tests _get_facet_data => sub { my $pass = Test2::Event::Pass->new(name => 'xxx'); is_deeply( _get_facet_data($pass), { about => {package => 'Test2::Event::Pass', details => 'pass', eid => $pass->eid}, assert => {pass => 1, details => 'xxx'}, }, "Got facet data from event" ); is_deeply( _get_facet_data({assert => {pass => 1}}), {assert => {pass => 1}}, "Facet data gets passed through" ); my $file = __FILE__; my $line; like( exception { $line = __LINE__; _get_facet_data([]) }, qr/'ARRAY\(.*\)' Does not appear to be either a Test::Event or an EventFacet hashref at \Q$file\E line $line/, "Must provide sane input data" ); { package Fake::Event; use base 'Test2::Event'; use Test2::Util::Facets2Legacy qw/causes_fail/; } my $e = Fake::Event->new(); like( exception { $line = __LINE__; $e->causes_fail }, qr/Cycle between Facets2Legacy and Fake::Event=HASH\(.*\)->facet_data\(\) \(Did you forget to override the facet_data\(\) method\?\)/, "Cannot depend on legacy facet_data and Facets2Legacy" ); }; tests causes_fail => sub { is(causes_fail({errors => [{fail => 1}]}), 1, "Fatal errors cause failure"); is(causes_fail({control => {terminate => 0}}), 0, "defined but 0 termination does not cause failure"); is(causes_fail({control => {terminate => 1}}), 1, "non-zero defined termination causes failure"); is(causes_fail({control => {halt => 1}}), 1, "A halt causes failure"); is(causes_fail({assert => {pass => 0}}), 1, "non-passign assert causes failure"); is(causes_fail({assert => {pass => 0}, amnesty => [{}]}), 0, "amnesty prevents assertion failure"); is(causes_fail({}), 0, "Default is no failure"); }; tests diagnostics => sub { is(diagnostics({}), 0, "Default is no"); is(diagnostics({errors => [{}]}), 1, "Errors mean diagnostics"); is(diagnostics({info => [{}]}), 0, "Info alone does not make diagnostics"); is(diagnostics({info => [{debug => 1}]}), 1, "Debug flag makes info diagnostics"); }; tests global => sub { is(global({}), 0, "not global by default"); is(global({control => {global => 0}}), 0, "global not set"); is(global({control => {global => 1}}), 1, "global is set"); }; tests increments_count => sub { is(increments_count({}), 0, "No count bump without an assertion"); is(increments_count({assert => {}}), 1, "count bump with assertion"); }; tests no_display => sub { is(no_display({}), 0, "default is no"); is(no_display({about => {no_display => 0}}), 0, "set to off"); is(no_display({about => {no_display => 1}}), 1, "set to on"); }; tests subtest_id => sub { is(subtest_id({}), undef, "none by default"); is(subtest_id({parent => {hid => 123}}), 123, "use parent hid when present"); }; tests summary => sub { is(summary({}), '', "no summary without about->details"); is(summary({about => {details => 'foo'}}), 'foo', "got about->details"); }; tests terminate => sub { is(terminate({}), undef, "undef by default"); is(terminate({control => {terminate => undef}}), undef, "undef by choice"); is(terminate({control => {terminate => 100}}), 100, "got the terminate value"); is(terminate({control => {terminate => 0}}), 0, "0 is passed through"); }; tests sets_plan => sub { is_deeply( [sets_plan({})], [], "No plan by default"); is_deeply( [sets_plan({plan => {}})], [0], "Empty plan means count of 0, nothing extra" ); is_deeply( [sets_plan({plan => {count => 100}})], [100], "Got simple count" ); is_deeply( [sets_plan({plan => {count => 0, none => 1}})], [0, 'NO PLAN'], "No Plan" ); is_deeply( [sets_plan({plan => {count => 0, skip => 1}})], [0, 'SKIP'], "Skip" ); is_deeply( [sets_plan({plan => {count => 0, skip => 1, details => 'foo bar'}})], [0, 'SKIP', 'foo bar'], "Skip with reason" ); }; done_testing; Control.t100644001750001750 132614772042323 23265 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Control'; my $CLASS = 'Test2::EventFacet::Control'; my $one = $CLASS->new(details => 'foo', global => 0, terminate => undef, halt => 0, has_callback => 1, encoding => 'utf8'); is($one->details, "foo", "Got details"); is($one->global, 0, "Got 'global' value"); is($one->terminate, undef, "Got 'terminate' value"); is($one->halt, 0, "Got 'halt' value"); is($one->has_callback, 1, "Got 'has_callback' value"); is($one->encoding, 'utf8', "Got 'utf8' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok(!$CLASS->is_list, "is not a list"); is($CLASS->facet_key, 'control', "Got key"); done_testing; Amnesty.t100644001750001750 100014772042323 23252 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/EventFacetuse strict; use warnings; use Test2::Tools::Tiny; use ok 'Test2::EventFacet::Amnesty'; my $CLASS = 'Test2::EventFacet::Amnesty'; my $one = $CLASS->new(details => 'foo', tag => 'bar', inherited => 0); is($one->details, "foo", "Got details"); is($one->tag, "bar", "Got tag"); is($one->inherited, 0, "Got 'inherited' value"); is_deeply($one->clone, $one, "Cloning."); isnt($one->clone, $one, "Clone is a new ref"); ok($CLASS->is_list, "is a list"); is($CLASS->facet_key, 'amnesty', "Got key"); done_testing; Legacy_And_Test2000755001750001750 014772042323 17670 5ustar00exodistexodist000000000000Test-Simple-1.302210/thidden_warnings.t100644001750001750 46314772042323 23343 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy_And_Test2use strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw( context_do ); $SIG{__WARN__} = sub { context_do { shift->throw("oops\n"); } $_[0]; }; my $array_var = []; eval { warn "trigger warning" }; my $err = $@; like( $err, qr/oops/, "Got expected error" ); done_testing(); AutomatedTesting.pm100644001750001750 234414772042323 23523 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::AutomatedTesting; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; sub skip { my $class = shift; return undef if $ENV{'AUTOMATED_TESTING'}; return 'Automated test, set the $AUTOMATED_TESTING environment variable to run it'; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Require::AutomatedTesting - Only run a test when the AUTOMATED_TESTING environment variable is set. =head1 DESCRIPTION It is common practice to write tests that are only run when the AUTOMATED_TESTING environment variable is set. This module automates the (admittedly trivial) work of creating such a test. =head1 SYNOPSIS use Test2::Require::AutomatedTesting; ... 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 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 Utilities.pm100644001750001750 312514772042323 23424 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Anatomypackage Test2::Manual::Anatomy::Utilities; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Migrating.pm100644001750001750 2353114772042323 23422 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Testingpackage Test2::Manual::Testing::Migrating; use strict; use warnings; our $VERSION = '1.302210'; 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 NOTE: srand When srand is on (default) it can cause problems with things like L which will end up attempting the same "random" filenames for every test process started on a given day (or sharing the same seed). If this is a problem for you then please disable srand when loading L: use Test2::V0 -no_srand => 1; =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 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 FirstTool.pm100644001750001750 705014772042323 23402 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Toolingpackage Test2::Manual::Tooling::FirstTool; our $VERSION = '1.302210'; 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 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 Formatter.pm100644001750001750 542314772042323 23422 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Toolingpackage Test2::Manual::Tooling::Formatter; our $VERSION = '1.302210'; 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 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 Event000755001750001750 014772042323 22001 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/AsyncSubtestDetach.t100644001750001750 171114772042323 23516 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/AsyncSubtest/Eventuse 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; Attach.t100644001750001750 164614772042323 23541 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/AsyncSubtest/Eventuse 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; Test-Refcount000755001750001750 014772042323 22073 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Tools02one.t100644001750001750 250614772042323 23346 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Tools/Test-Refcount#!/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; dont_overwrite_die_handler.t100644001750001750 100314772042323 23734 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w use Config; # To prevent conflict with some strawberry-portable versions BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use Carp qw/cluck/; # Make sure this is in place before Test::More is loaded. my $started = 0; my $handler_called; BEGIN { $SIG{__DIE__} = sub { $handler_called++; cluck 'Died early!' unless $started }; } use Test::More tests => 2; $started = 1; ok !eval { die }; is $handler_called, 1, 'existing DIE handler not overridden'; tbm_doesnt_set_exported_to.t100644001750001750 71114772042323 23756 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy#!/usr/bin/perl -w BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = '../lib'; } } use strict; use warnings; # Can't use Test::More, that would set exported_to() use Test::Builder; use Test::Builder::Module; my $TB = Test::Builder->create; $TB->plan( tests => 1 ); $TB->level(0); $TB->is_eq( Test::Builder::Module->builder->exported_to, undef, 'using Test::Builder::Module does not set exported_to()' ); 683_thread_todo.t100644001750001750 65314772042323 23352 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Regressionuse strict; use warnings; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; use Test::More; my $t = threads->create( sub { local $TODO = "Some good reason"; fail "Crap"; 42; } ); is( $t->join, 42, "Thread exited successfully" ); done_testing; 27-1-Test2-Bundle-More.t100644001750001750 21414772042323 22777 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::Bundle::More; use strict; use warnings; is_deeply({a => [1]}, {a => [1]}, "is_deeply() works, stuff is loaded"); done_testing; skip_reason_object_ipc.t100644001750001750 104414772042323 24023 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::Tools::Tiny; use strict; use warnings; use Test2::IPC; use Test::Builder; use Test2::Util qw/CAN_REALLY_FORK/; skip_all 'No IPC' unless CAN_REALLY_FORK; ok(1, "pre-test"); my $pid = fork; die "Could not fork: $!" unless defined $pid; if ($pid) { my $ret = waitpid($pid, 0); is($ret, $pid, "Got correct pid"); is($?, 0, "Exited without issue"); } else { ok(1, "A test"); my $obj = bless({foo => \*STDOUT}, 'FOO'); Test::Builder->new->skip($obj, $obj); ok(1, "Another Test"); exit 0; } done_testing; 696-intercept_skip_all.t100644001750001750 175514772042323 23533 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept/; tests in_eval => sub { my $events = intercept { eval { skip_all "foo" }; die "Should not see this: $@"; }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); is($events->[0]->directive, 'SKIP', "Plan is to skip"); }; tests no_eval => sub { my $events = intercept { skip_all "foo"; die "Should not see this: $@"; }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); is($events->[0]->directive, 'SKIP', "Plan is to skip"); }; tests in_require => sub { my $events = intercept { require './t/lib/SkipAll.pm'; die "Should not see this: $@"; }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "Plan is only event"); is($events->[0]->directive, 'SKIP', "Plan is to skip"); }; done_testing; InterceptResult.t100644001750001750 2075114772042323 23411 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/APIuse strict; use warnings; use Test::Builder; use Test2::Tools::Tiny; use Test2::API::InterceptResult; use Scalar::Util qw/reftype/; use Test2::API qw/intercept context/; my $CLASS = 'Test2::API::InterceptResult'; tests construction => sub { my $one = $CLASS->new('a'); ok($one->isa($CLASS), "Got an instance"); is(reftype($one), 'ARRAY', "Blessed arrayref"); is_deeply($one, ['a'], "Ref looks good."); my $two = $CLASS->new_from_ref(['a']); ok($two->isa($CLASS), "Got an instance"); is(reftype($two), 'ARRAY', "Blessed arrayref"); is_deeply($two, ['a'], "Ref looks good."); my $three = $two->clone; ok($three->isa($CLASS), "Got an instance"); is(reftype($three), 'ARRAY', "Blessed arrayref"); is_deeply($three, ['a'], "Ref looks good."); push @$two => 'b'; is_deeply($two, ['a', 'b'], "Modified two"); is_deeply($three, ['a'], "three was not changed"); my $four = intercept { ok(1, "Pass"); }; ok($four->isa($CLASS), "Intercept returns an instance"); }; tests event_list => sub { my $one = $CLASS->new('a', 'b'); is_deeply([$one->event_list], ['a', 'b'], "event_list is essentially \@{\$self}"); }; tests _upgrade => sub { require Test2::Event::Pass; my $event = Test2::Event::Pass->new(name => 'soup for you', trace => {frame => ['foo', 'foo.pl', 42]}); ok($event->isa('Test2::Event'), "Start with an event"); my $one = $CLASS->new; my $up = $one->_upgrade($event); ok($up->isa('Test2::API::InterceptResult::Event'), "Upgraded the event"); is($up->result_class, $CLASS, "set the result class"); is_deeply($event->facet_data, $up->facet_data, "Facet data is identical"); $up->facet_data->{trace}->{frame}->[2] = 43; is($up->trace_line, 43, "Modified the facet data in the upgraded clone"); is($event->facet_data->{trace}->{frame}->[2], 42, "Did not modify the original"); my $up2 = $one->_upgrade($up); is("$up2", "$up", "Returned the ref unmodified because it is already an upgraded item"); require Test2::Event::V2; my $subtest = 'Test2::Event::V2'->new( trace => {frame => ['foo', 'foo.pl', 42]}, assert => {pass => 1, details => 'pass'}, parent => { hid => 1, children => [ $event ], }, ); my $subup = $one->_upgrade($subtest); ok($subup->the_subtest->{children}->isa($CLASS), "Blessed subtest subevents"); ok( $subup->the_subtest->{children}->[0]->isa('Test2::API::InterceptResult::Event'), "Upgraded the children" ); }; tests hub => sub { my $one = intercept { ok(1, "pass"); ok(0, "fail"); plan 2; }; my $hub = $one->hub; ok($hub->isa('Test2::Hub'), "Hub is a proper instance"); ok($hub->check_plan, "Had a plan and followed it"); is($hub->count, 2, "saw both events"); is($hub->failed, 1, "saw a failure"); ok($hub->ended, "Hub ended"); is_deeply( $one->state, { count => 2, failed => 1, is_passing => 0, plan => 2, bailed_out => undef, skip_reason => undef, follows_plan => 1, }, "Got the hub state" ); }; tests upgrade => sub { my $one = intercept { require Test::More; Test::More::ok(1, "pass"); Test::More::ok(1, "pass"); }; ok($one->[0]->isa('Test2::Event::Ok'), "Original event is not upgraded 0"); ok($one->[1]->isa('Test2::Event::Ok'), "Original event is not upgraded 1"); my $two = $one->upgrade; ok($one->[0]->isa('Test2::Event::Ok'), "Did not modify original 0"); ok($one->[0]->isa('Test2::Event::Ok'), "Did not modify original 1"); ok($two->[0]->isa('Test2::API::InterceptResult::Event'), "Upgraded copy 0"); ok($two->[1]->isa('Test2::API::InterceptResult::Event'), "Upgraded copy 1"); my $three = $two->upgrade; ok("$two->[0]" ne "$three->[0]", "Upgrade on an already upgraded instance returns copies of the events, not originals"); like( exception { $one->upgrade() }, qr/Called a method that creates a new instance in void context/, "Calling upgrade() without keeping the result is a bug" ); $one->upgrade(in_place => 1); ok($one->[0]->isa('Test2::API::InterceptResult::Event'), "Upgraded in place 0"); ok($one->[1]->isa('Test2::API::InterceptResult::Event'), "Upgraded in place 1"); }; tests squash_info => sub { my $one = intercept { diag "isolated 1"; note "isolated 2"; sub { my $ctx = context(); diag "inline 1"; note "inline 2"; $ctx->fail; diag "inline 3"; note "inline 4"; $ctx->release; }->(); diag "isolated 3"; note "isolated 4"; }; my $new = $one->squash_info; $one->squash_info(in_place => 1); is_deeply( $new, $one, "Squash and squash in place produce the same result" ); is(@$one, 5, "5 events after squash"); is_deeply([$one->[0]->info_messages], ['isolated 1'], "First event not modified"); is_deeply([$one->[1]->info_messages], ['isolated 2'], "Second event not modified"); is_deeply([$one->[3]->info_messages], ['isolated 3'], "second to last event not modified"); is_deeply([$one->[4]->info_messages], ['isolated 4'], "last event not modified"); is_deeply( [$one->[2]->info_messages], [ 'inline 1', 'inline 2', 'inline 3', 'inline 4', ], "Assertion collected info generated in the same context" ); ok($one->[2]->has_assert, "Assertion is still an assertion"); my $two = intercept { }; }; tests messages => sub { my $one = intercept { note "foo"; diag "bar"; ok(1); sub { my $ctx = context(); $ctx->send_ev2( errors => [ {tag => 'error', details => "Error 1" }, {tag => 'error', details => "Error 2" }, ], info => [ {tag => 'DIAG', details => 'Diag 1'}, {tag => 'DIAG', details => 'Diag 2'}, {tag => 'NOTE', details => 'Note 1'}, {tag => 'NOTE', details => 'Note 2'}, ], ); $ctx->release; }->(); note "baz"; diag "bat"; }; is_deeply( $one->diag_messages, ['bar', 'Diag 1', 'Diag 2', 'bat'], "Got diags" ); is_deeply( $one->note_messages, ['foo', 'Note 1', 'Note 2', 'baz'], "Got Notes" ); is_deeply( $one->error_messages, ['Error 1', 'Error 2'], "Got errors" ); }; tests grep => sub { my $one = intercept { ok(1), # 0 note "A Note"; # 1 diag "A Diag"; # 2 tests foo => sub { ok(1) }; # 3 sub { # 4 my $ctx = context(); $ctx->send_ev2(errors => [{tag => 'error', details => "Error 1"}]); $ctx->release; }->(); # 4 plan 2; # 5 }; $one->upgrade(in_place => 1); is_deeply($one->asserts, [$one->[0], $one->[3]], "Got the asserts"); is_deeply($one->subtests, [$one->[3]], "Got the subtests"); is_deeply($one->diags, [$one->[2]], "Got the diags"); is_deeply($one->notes, [$one->[1]], "Got the notes"); is_deeply($one->errors, [$one->[4]], "Got the errors"); is_deeply($one->plans, [$one->[5]], "Got the plans"); $one->asserts(in_place => 1); is(@$one, 2, "2 events"); ok($_->has_assert, "Is an assert") for @$one; }; tests map => sub { my $one = intercept { ok(1); ok(2) }; $one->upgrade(in_place => 1); is_deeply( $one->flatten, [ $one->[0]->flatten, $one->[1]->flatten ], "Flattened both events" ); is_deeply( $one->briefs, [ $one->[0]->brief, $one->[1]->brief ], "Brief of both events" ); is_deeply( $one->summaries, [ $one->[0]->summary, $one->[1]->summary ], "Summaries of both events" ); my $two = intercept { tests foo => sub { ok(1) }; ok(1); tests bar => sub { ok(1) }; }->upgrade; is_deeply( $two->subtest_results, [ $two->[0]->subtest_result, $two->[2]->subtest_result ], "Got subtest results" ); }; done_testing; 693_ipc_ordering.t100644001750001750 114214772042323 23372 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/regressionuse Test2::Tools::Tiny; use strict; use warnings; skip_all("Test cannot run on perls below 5.8.8") unless "$]" > 5.008007; use Test2::Util qw/CAN_THREAD/; use Test2::IPC; use Test2::API qw/context intercept/; skip_all('System does not have threads') unless CAN_THREAD(); require threads; threads->import; my $events = intercept { threads->create( sub { ok 1, "something $_ nonlocal" for (1 .. 15); } )->join; }; is_deeply( [map { $_->{name} } @$events], [map "something $_ nonlocal", 1 .. 15], "Culled sub-thread events in correct order" ); done_testing; diag_event_on_ok.t100644001750001750 76314772042323 23475 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy_And_Test2use strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/intercept/; use Test::More (); my $events = intercept { Test::More::ok(0, 'name'); }; my ($ok, $diag) = @$events; ok($ok->isa('Test2::Event::Ok'), "got 'ok' result"); is($ok->pass, 0, "'ok' test failed"); is($ok->name, 'name', "got 'ok' name"); ok($diag->isa('Test2::Event::Diag'), "got 'ok' result"); is($diag->message, " Failed test 'name'\n at $0 line 9.\n", "got all diag message in one diag event"); done_testing; Event000755001750001750 014772042323 21635 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/AsyncSubtestAttach.pm100644001750001750 326114772042323 23541 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/AsyncSubtest/Eventpackage Test2::AsyncSubtest::Event::Attach; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Detach.pm100644001750001750 327314772042323 23530 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/AsyncSubtest/Eventpackage Test2::AsyncSubtest::Event::Detach; use strict; use warnings; our $VERSION = '1.302210'; 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 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 Facet.pm100644001750001750 57414772042323 23400 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/API/InterceptResultpackage Test2::API::InterceptResult::Facet; use strict; use warnings; our $VERSION = '1.302210'; BEGIN { require Test2::EventFacet; our @ISA = ('Test2::EventFacet'); } our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $name = $AUTOLOAD; $name =~ s/^.*:://g; return undef unless exists $self->{$name}; return $self->{$name}; } sub DESTROY {} 1; Event.pm100644001750001750 7014714772042323 23502 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/API/InterceptResultpackage Test2::API::InterceptResult::Event; use strict; use warnings; our $VERSION = '1.302210'; use List::Util qw/first/; use Test2::Util qw/pkg_to_file/; use Scalar::Util qw/reftype blessed/; use Storable qw/dclone/; use Carp qw/confess croak/; use Test2::API::InterceptResult::Facet; use Test2::API::InterceptResult::Hub; use Test2::Util::HashBase qw{ +causes_failure import( # We will replace the sub later require => 1, on_require_error => sub { 1 }, search_path => ['Test2::EventFacet'], max_depth => 3, min_depth => 3, ); for my $facet_type (__PACKAGE__->plugins) { my ($key, $list); eval { $key = $facet_type->facet_key; $list = $facet_type->is_list; }; next unless $key && defined($list); $FACETS{$key} = {list => $list, class => $facet_type, loaded => 1}; } } $FACETS{__GENERIC__} = {class => 'Test2::API::InterceptResult::Facet', loaded => 1}; } sub facet_map { \%FACETS } sub facet_info { my $facet = pop; return $FACETS{$facet} if exists $FACETS{$facet}; my $mname = ucfirst(lc($facet)); $mname =~ s/s$//; for my $name ($mname, "${mname}s") { my $file = "Test2/EventFacet/$name.pm"; my $class = "Test2::EventFacet::$name"; local $@; my $ok = eval { require $file; my $key = $class->facet_key; my $list = $class->is_list; $FACETS{$key} = {list => $list, class => $class, loaded => 1}; $FACETS{$facet} = $FACETS{$key} if $facet ne $key; 1; }; return $FACETS{$facet} if $ok && $FACETS{$facet}; } return $FACETS{$facet} = $FACETS{__GENERIC__}; } sub init { my $self = shift; my $rc = $self->{+RESULT_CLASS} ||= 'Test2::API::InterceptResult'; my $rc_file = pkg_to_file($rc); require($rc_file) unless $INC{$rc_file}; my $fd = $self->{+FACET_DATA} ||= {}; for my $facet (keys %$fd) { my $finfo = $self->facet_info($facet); my $is_list = $finfo->{list}; next unless defined $is_list; my $type = reftype($fd->{$facet}); if ($is_list) { confess "Facet '$facet' is a list facet, but got '$type' instead of an arrayref" unless $type eq 'ARRAY'; for my $item (@{$fd->{$facet}}) { my $itype = reftype($item); next if $itype eq 'HASH'; confess "Got item type '$itype' in list-facet '$facet', all items must be hashrefs"; } } else { confess "Facet '$facet' is an only-one facet, but got '$type' instead of a hashref" unless $type eq 'HASH'; } } } sub clone { my $self = shift; my $class = blessed($self); my %data = %$self; $data{+FACET_DATA} = dclone($data{+FACET_DATA}); return bless(\%data, $class); } sub _facet_class { my $self = shift; my ($name) = @_; my $spec = $self->facet_info($name); my $class = $spec->{class}; unless ($spec->{loaded}) { my $file = pkg_to_file($class); require $file unless $INC{$file}; $spec->{loaded} = 1; } return $class; } sub the_facet { my $self = shift; my ($name) = @_; return undef unless defined $self->{+FACET_DATA}->{$name}; my $data = $self->{+FACET_DATA}->{$name}; my $type = reftype($data) or confess "Facet '$name' has a value that is not a reference, this should not happen"; return $self->_facet_class($name)->new(%{dclone($data)}) if $type eq 'HASH'; if ($type eq 'ARRAY') { return undef unless @$data; croak "'the_facet' called for facet '$name', but '$name' has '" . @$data . "' items" if @$data != 1; return $self->_facet_class($name)->new(%{dclone($data->[0])}); } die "Invalid facet data type: $type"; } sub facet { my $self = shift; my ($name) = @_; return () unless exists $self->{+FACET_DATA}->{$name}; my $data = $self->{+FACET_DATA}->{$name}; my $type = reftype($data) or confess "Facet '$name' has a value that is not a reference, this should not happen"; my @out; @out = ($data) if $type eq 'HASH'; @out = (@$data) if $type eq 'ARRAY'; my $class = $self->_facet_class($name); return map { $class->new(%{dclone($_)}) } @out; } sub causes_failure { my $self = shift; return $self->{+CAUSES_FAILURE} if exists $self->{+CAUSES_FAILURE}; my $hub = Test2::API::InterceptResult::Hub->new(); $hub->process($self); return $self->{+CAUSES_FAILURE} = ($hub->is_passing ? 0 : 1); } sub causes_fail { shift->causes_failure } sub trace { $_[0]->facet('trace') } sub the_trace { $_[0]->the_facet('trace') } sub frame { my $t = $_[0]->the_trace or return undef; $t->{frame} || undef } sub trace_details { my $t = $_[0]->the_trace or return undef; $t->{details} || undef } sub trace_stamp { my $f = $_[0]->the_trace or return undef; $f->{stamp} || undef } sub trace_package { my $f = $_[0]->frame or return undef; $f->[0] || undef } sub trace_file { my $f = $_[0]->frame or return undef; $f->[1] || undef } sub trace_line { my $f = $_[0]->frame or return undef; $f->[2] || undef } sub trace_subname { my $f = $_[0]->frame or return undef; $f->[3] || undef } sub trace_tool { my $f = $_[0]->frame or return undef; $f->[3] || undef } sub trace_signature { my $t = $_[0]->the_trace or return undef; Test2::EventFacet::Trace::signature($t) || undef } sub brief { my $self = shift; my @try = qw{ bailout_brief error_brief assert_brief plan_brief }; for my $meth (@try) { my $got = $self->$meth or next; return $got; } return; } sub flatten { my $self = shift; my %params = @_; my $todo = {%{$self->{+FACET_DATA}}}; delete $todo->{hubs}; delete $todo->{meta}; delete $todo->{trace}; my $out = $self->summary; delete $out->{brief}; delete $out->{facets}; delete $out->{trace_tool}; delete $out->{trace_details} unless defined($out->{trace_details}); for my $tagged (grep { my $finfo = $self->facet_info($_); $finfo->{list} && $finfo->{class}->can('tag') } keys %FACETS, keys %$todo) { my $set = delete $todo->{$tagged} or next; my $fd = $self->{+FACET_DATA}; my $has_assert = $self->has_assert; my $has_parent = $self->has_subtest; my $has_fatal_error = $self->has_errors && grep { $_->{fail} } $self->errors; next if $tagged eq 'amnesty' && !($has_assert || $has_parent || $has_fatal_error); for my $item (@$set) { push @{$out->{lc($item->{tag})}} => $item->{fail} ? "FATAL: $item->{details}" : $item->{details}; } } if (my $assert = delete $todo->{assert}) { $out->{pass} = $assert->{pass}; $out->{name} = $assert->{details}; } if (my $parent = delete $todo->{parent}) { delete $out->{subtest}->{bailed_out} unless defined $out->{subtest}->{bailed_out}; delete $out->{subtest}->{skip_reason} unless defined $out->{subtest}->{skip_reason}; if (my $res = $self->subtest_result) { my $state = $res->state; delete $state->{$_} for grep { !defined($state->{$_}) } keys %$state; $out->{subtest} = $state; $out->{subevents} = $res->flatten(%params) if $params{include_subevents}; } } if (my $control = delete $todo->{control}) { if ($control->{halt}) { $out->{bailed_out} = $control->{details} || 1; } elsif(defined $control->{details}) { $out->{control} = $control->{details}; } } if (my $plan = delete $todo->{plan}) { $out->{plan} = $self->plan_brief; $out->{plan} =~ s/^PLAN\s*//; } for my $other (keys %$todo) { my $data = $todo->{$other} or next; if (reftype($data) eq 'ARRAY') { if (!$out->{$other} || reftype($out->{$other}) eq 'ARRAY') { for my $item (@$data) { push @{$out->{$other}} => $item->{details} if defined $item->{details}; } } } else { $out->{$other} = $data->{details} if defined($data->{details}) && !defined($out->{$other}); } } if (my $fields = $params{fields}) { $out = { map {exists($out->{$_}) ? ($_ => $out->{$_}) : ()} @$fields }; } if (my $remove = $params{remove}) { delete $out->{$_} for @$remove; } return $out; } sub summary { my $self = shift; my %params = @_; my $out = { brief => $self->brief || '', causes_failure => $self->causes_failure, trace_line => $self->trace_line, trace_file => $self->trace_file, trace_tool => $self->trace_subname, trace_details => $self->trace_details, facets => [ sort keys(%{$self->{+FACET_DATA}}) ], }; if (my $fields = $params{fields}) { $out = { map {exists($out->{$_}) ? ($_ => $out->{$_}) : ()} @$fields }; } if (my $remove = $params{remove}) { delete $out->{$_} for @$remove; } return $out; } sub has_assert { $_[0]->{+FACET_DATA}->{assert} ? 1 : 0 } sub the_assert { $_[0]->the_facet('assert') } sub assert { $_[0]->facet('assert') } sub assert_brief { my $self = shift; my $fd = $self->{+FACET_DATA}; my $as = $fd->{assert} or return; my $am = $fd->{amnesty}; my $out = $as->{pass} ? "PASS" : "FAIL"; $out .= " with amnesty" if $am; return $out; } sub has_subtest { $_[0]->{+FACET_DATA}->{parent} ? 1 : 0 } sub the_subtest { $_[0]->the_facet('parent') } sub subtest { $_[0]->facet('parent') } sub subtest_result { my $self = shift; my $parent = $self->{+FACET_DATA}->{parent} or return; my $children = $parent->{children} || []; $children = $self->{+RESULT_CLASS}->new(@$children)->upgrade unless blessed($children) && $children->isa($self->{+RESULT_CLASS}); return $children; } sub has_bailout { $_[0]->bailout ? 1 : 0 } sub the_bailout { my ($b) = $_[0]->bailout; $b } sub bailout { my $self = shift; my $control = $self->{+FACET_DATA}->{control} or return; return $control if $control->{halt}; return; } sub bailout_brief { my $self = shift; my $bo = $self->bailout or return; my $reason = $bo->{details} or return "BAILED OUT"; return "BAILED OUT: $reason"; } sub bailout_reason { my $self = shift; my $bo = $self->bailout or return; return $bo->{details} || ''; } sub has_plan { $_[0]->{+FACET_DATA}->{plan} ? 1 : 0 } sub the_plan { $_[0]->the_facet('plan') } sub plan { $_[0]->facet('plan') } sub plan_brief { my $self = shift; my $plan = $self->{+FACET_DATA}->{plan} or return; my $base = $self->_plan_brief($plan); my $reason = $plan->{details} or return $base; return "$base: $reason"; } sub _plan_brief { my $self = shift; my ($plan) = @_; return 'NO PLAN' if $plan->{none}; return "SKIP ALL" if $plan->{skip} || !$plan->{count}; return "PLAN $plan->{count}"; } sub has_amnesty { $_[0]->{+FACET_DATA}->{amnesty} ? 1 : 0 } sub the_amnesty { $_[0]->the_facet('amnesty') } sub amnesty { $_[0]->facet('amnesty') } sub amnesty_reasons { map { $_->{details} } $_[0]->amnesty } sub has_todos { &first(sub { uc($_->{tag}) eq 'TODO' }, $_[0]->amnesty) ? 1 : 0 } sub todos { grep { uc($_->{tag}) eq 'TODO' } $_[0]->amnesty } sub todo_reasons { map { $_->{details} || 'TODO' } $_[0]->todos } sub has_skips { &first(sub { uc($_->{tag}) eq 'SKIP' }, $_[0]->amnesty) ? 1 : 0 } sub skips { grep { uc($_->{tag}) eq 'SKIP' } $_[0]->amnesty } sub skip_reasons { map { $_->{details} || 'SKIP' } $_[0]->skips } my %TODO_OR_SKIP = (SKIP => 1, TODO => 1); sub has_other_amnesty { &first( sub { !$TODO_OR_SKIP{uc($_->{tag})} }, $_[0]->amnesty) ? 1 : 0 } sub other_amnesty { grep { !$TODO_OR_SKIP{uc($_->{tag})} } $_[0]->amnesty } sub other_amnesty_reasons { map { $_->{details} || $_->{tag} || 'AMNESTY' } $_[0]->other_amnesty } sub has_errors { $_[0]->{+FACET_DATA}->{errors} ? 1 : 0 } sub the_errors { $_[0]->the_facet('errors') } sub errors { $_[0]->facet('errors') } sub error_messages { map { $_->{details} || $_->{tag} || 'ERROR' } $_[0]->errors } sub error_brief { my $self = shift; my $errors = $self->{+FACET_DATA}->{errors} or return; my $base = @$errors > 1 ? "ERRORS" : "ERROR"; return $base unless @$errors; my ($msg, @extra) = split /[\n\r]+/, $errors->[0]->{details}; my $out = "$base: $msg"; $out .= " [...]" if @extra || @$errors > 1; return $out; } sub has_info { $_[0]->{+FACET_DATA}->{info} ? 1 : 0 } sub the_info { $_[0]->the_facet('info') } sub info { $_[0]->facet('info') } sub info_messages { map { $_->{details} } $_[0]->info } sub has_diags { &first(sub { uc($_->{tag}) eq 'DIAG' }, $_[0]->info) ? 1 : 0 } sub diags { grep { uc($_->{tag}) eq 'DIAG' } $_[0]->info } sub diag_messages { map { $_->{details} || 'DIAG' } $_[0]->diags } sub has_notes { &first(sub { uc($_->{tag}) eq 'NOTE' }, $_[0]->info) ? 1 : 0 } sub notes { grep { uc($_->{tag}) eq 'NOTE' } $_[0]->info } sub note_messages { map { $_->{details} || 'NOTE' } $_[0]->notes } my %NOTE_OR_DIAG = (NOTE => 1, DIAG => 1); sub has_other_info { &first(sub { !$NOTE_OR_DIAG{uc($_->{tag})} }, $_[0]->info) ? 1 : 0 } sub other_info { grep { !$NOTE_OR_DIAG{uc($_->{tag})} } $_[0]->info } sub other_info_messages { map { $_->{details} || $_->{tag} || 'INFO' } $_[0]->other_info } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult::Event - Representation of an event for use in testing other test tools. =head1 DESCRIPTION C from L returns an instance of L which is a blessed arrayref of L objects. This POD documents the methods of these events, which are mainly provided for you to use when testing your test tools. =head1 SYNOPSIS use Test2::V0; use Test2::API qw/intercept/; my $events = intercept { ok(1, "A passing assertion"); plan(1); }; # This will convert all events into instances of # Test2::API::InterceptResult::Event. Until we do this they are the # original Test::Event::* instances $events->upgrade(in_place => 1); # Now we can get individual events in this form my $assert = $events->[0]; my $plan = $events->[1]; # Or we can operate on all events at once: my $flattened = $events->flatten; is( $flattened, [ { causes_failure => 0, name => 'A passing assertion', pass => 1, trace_file => 'xxx.t', trace_line => 5, }, { causes_failure => 0, plan => 1, trace_file => 'xxx.t', trace_line => 6, }, ], "Flattened both events and returned an arrayref of the results ); =head1 METHODS =head2 !!! IMPORTANT NOTES ON DESIGN !!! Please pay attention to what these return, many return a scalar when applicable or an empty list when not (as opposed to undef). Many also always return a list of 0 or more items. Some always return a scalar. Note that none of the methods care about context, their behavior is consistent regardless of scalar, list, or void context. This was done because this class was specifically designed to be used in a list and generate more lists in bulk operations. Sometimes in a map you want nothing to show up for the event, and you do not want an undef in its place. In general single event instances are not going to be used alone, though that is allowed. As a general rule any method prefixed with C implies the event should have exactly 1 of the specified item, and and exception will be thrown if there are 0, or more than 1 of the item. =head2 ATTRIBUTES =over 4 =item $hashref = $event->facet_data This will return the facet data hashref, which is all Test2 cares about for any given event. =item $class = $event->result_class This is normally L. This is set at construction so that subtest results can be turned into instances of it on demand. =back =head2 DUPLICATION =over 4 =item $copy = $event->clone Create a deep copy of the event. Modifying either event will not affect the other. =back =head2 CONDENSED MULTI-FACET DATA =over 4 =item $bool = $event->causes_failure =item $bool = $event->causes_fail These are both aliases of the same functionality. This will always return either a true value, or a false value. This never returns a list. This method may be relatively slow (still super fast) because it determines pass or fail by creating an instance of L and asking it to process the event, and then asks the hub for its pass/fail state. This is slower than building in logic to do the check, but it is more reliable as it will always tell you what the hub thinks, so the logic will never be out of date relative to the Test2 logic that actually cares. =item STRING_OR_EMPTY_LIST = $event->brief Not all events have a brief, some events are not rendered by the formatter, others have no "brief" data worth seeing. When this is the case an empty list is returned. This is done intentionally so it can be used in a map operation without having C being included in the result. When a brief can be generated it is always a single 1-line string, and is returned as-is, not in a list. Possible briefs: # From control facets "BAILED OUT" "BAILED OUT: $why" # From error facets "ERROR" "ERROR: $message" "ERROR: $partial_message [...]" "ERRORS: $first_error_message [...]" # From assert facets "PASS" "FAIL" "PASS with amnesty" "FAIL with amnesty" # From plan facets "PLAN $count" "NO PLAN" "SKIP ALL" "SKIP ALL: $why" Note that only the first applicable brief is returned. This is essentially a poor-mans TAP that only includes facets that could (but not necessarily do) cause a failure. =item $hashref = $event->flatten =item $hashref = $event->flatten(include_subevents => 1) This ALWAYS returns a hashref. This puts all the most useful data for the most interesting facets into a single hashref for easy validation. If there are no meaningful facets this will return an empty hashref. If given the 'include_subevents' parameter it will also include subtest data: Here is a list of EVERY possible field. If a field is not applicable it will not be present. =over 4 =item always present causes_failure => 1, # Always present =item Present if the event has a trace facet trace_line => 42, trace_file => 'Foo/Bar.pm', trace_details => 'Extra trace details', # usually not present =item If an assertion is present pass => 0, name => "1 + 1 = 2, so math works", =item If a plan is present: plan => $count_or_SKIP_ALL_or_NO_PLAN, =item If amnesty facets are present You get an array for each type that is present. todo => [ # Yes you could be under multiple todos, this will list them all. "I will fix this later", "I promise to fix these", ], skip => ["This will format the main drive, do not run"], ... => ["Other amnesty"] =item If Info (note/diag) facets are present You get an arrayref for any that are present, the key is not defined if they are not present. diag => [ "Test failed at Foo/Bar.pm line 42", "You forgot to tie your boots", ], note => ["Your boots are red"], ... => ["Other info"], =item If error facets are present Always an arrayref error => [ "non fatal error (does not cause test failure, just an FYI", "FATAL: This is a fatal error (causes failure)", ], # Errors can have alternative tags, but in practice are always 'error', # listing this for completeness. ... => [ ... ] =item Present if the event is a subtest subtest => { count => 2, # Number of assertions made failed => 1, # Number of test failures seen is_passing => 0, # Boolean, true if the test would be passing # after the events are processed. plan => 2, # Plan, either a number, undef, 'SKIP', or 'NO PLAN' follows_plan => 1, # True if there is a plan and it was followed. # False if the plan and assertions did not # match, undef if no plan was present in the # event list. bailed_out => "foo", # if there was a bail-out in the # events in this will be a string explaining # why there was a bailout, if no reason was # given this will simply be set to true (1). skip_reason => "foo", # If there was a skip_all this will give the # reason. }, if C<< (include_subtest => 1) >> was provided as a parameter then the following will be included. This is the result of turning all subtest child events into an L instance and calling the C method on it. subevents => Test2::API::InterceptResult->new(@child_events)->flatten(...), =item If a bail-out is being requested If no reason was given this will be set to 1. bailed_out => "reason", =back =item $hashref = $event->summary() This returns a limited summary. See C, which is usually a better option. { brief => $event->brief || '', causes_failure => $event->causes_failure, trace_line => $event->trace_line, trace_file => $event->trace_file, trace_tool => $event->trace_subname, trace_details => $event->trace_details, facets => [ sort keys(%{$event->{+FACET_DATA}}) ], } =back =head2 DIRECT ARBITRARY FACET ACCESS =over 4 =item @list_of_facets = $event->facet($name) This always returns a list of 0 or more items. This fetches the facet instances from the event. For facets like 'assert' this will always return 0 or 1 item. For events like 'info' (diags, notes) this will return 0 or more instances, once for each instance of the facet. These will be blessed into the proper L subclass. If no subclass can be found it will be blessed as an L generic facet class. =item $undef_or_facet = $event->the_facet($name) If you know you will have exactly 1 instance of a facet you can call this. If you are correct and there is exactly one instance of the facet it will always return the hashref. If there are 0 instances of the facet this will return undef, not an empty list. If there are more than 1 instance this will throw an exception because your assumption was incorrect. =back =head2 TRACE FACET =over 4 =item @list_of_facets = $event->trace TODO =item $undef_or_hashref = $event->the_trace This returns the trace hashref, or undef if it is not present. =item $undef_or_arrayref = $event->frame If a trace is present, and has a caller frame, this will be an arrayref: [$package, $file, $line, $subname] If the trace is not present, or has no caller frame this will return undef. =item $undef_or_string = $event->trace_details This is usually undef, but occasionally has a string that overrides the file/line number debugging a trace usually provides on test failure. =item $undef_or_string = $event->trace_package Same as C<(caller())[0]>, the first element of the trace frame. Will be undef if not present. =item $undef_or_string = $event->trace_file Same as C<(caller())[1]>, the second element of the trace frame. Will be undef if not present. =item $undef_or_integer = $event->trace_line Same as C<(caller())[2]>, the third element of the trace frame. Will be undef if not present. =item $undef_or_string = $event->trace_subname =item $undef_or_string = $event->trace_tool Aliases for the same thing Same as C<(caller($level))[4]>, the fourth element of the trace frame. Will be undef if not present. =item $undef_or_string = $event->trace_signature A string that is a unique signature for the trace. If a single context generates multiple events they will all have the same signature. This can be used to tie assertions and diagnostics sent as separate events together after the fact. =back =head2 ASSERT FACET =over 4 =item $bool = $event->has_assert Returns true if the event has an assert facet, false if it does not. =item $undef_or_hashref = $event->the_assert Returns the assert facet if present, undef if it is not. =item @list_of_facets = $event->assert TODO =item EMPTY_LIST_OR_STRING = $event->assert_brief Returns a string giving a brief of the assertion if an assertion is present. Returns an empty list if no assertion is present. =back =head2 SUBTESTS (PARENT FACET) =over 4 =item $bool = $event->has_subtest True if a subetest is present in this event. =item $undef_or_hashref = $event->the_subtest Get the one subtest if present, otherwise undef. =item @list_of_facets = $event->subtest TODO =item EMPTY_LIST_OR_OBJECT = $event->subtest_result Returns an empty list if there is no subtest. Get an instance of L representing the subtest. =back =head2 CONTROL FACET (BAILOUT, ENCODING) =over 4 =item $bool = $event->has_bailout True if there was a bailout =item $undef_hashref = $event->the_bailout Return the control facet if it requested a bailout. =item EMPTY_LIST_OR_HASHREF = $event->bailout Get a list of 0 or 1 hashrefs. The hashref will be the control facet if a bail-out was requested. =item EMPTY_LIST_OR_STRING = $event->bailout_brief Get the brief of the bailout if present. =item EMPTY_LIST_OR_STRING = $event->bailout_reason Get the reason for the bailout, an empty string if no reason was provided, or an empty list if there was no bailout. =back =head2 PLAN FACET TODO =over 4 =item $bool = $event->has_plan =item $undef_or_hashref = $event->the_plan =item @list_if_hashrefs = $event->plan =item EMPTY_LIST_OR_STRING $event->plan_brief =back =head2 AMNESTY FACET (TODO AND SKIP) TODO =over 4 =item $event->has_amnesty =item $event->the_amnesty =item $event->amnesty =item $event->amnesty_reasons =item $event->has_todos =item $event->todos =item $event->todo_reasons =item $event->has_skips =item $event->skips =item $event->skip_reasons =item $event->has_other_amnesty =item $event->other_amnesty =item $event->other_amnesty_reasons =back =head2 ERROR FACET (CAPTURED EXCEPTIONS) TODO =over 4 =item $event->has_errors =item $event->the_errors =item $event->errors =item $event->error_messages =item $event->error_brief =back =head2 INFO FACET (DIAG, NOTE) TODO =over 4 =item $event->has_info =item $event->the_info =item $event->info =item $event->info_messages =item $event->has_diags =item $event->diags =item $event->diag_messages =item $event->has_notes =item $event->notes =item $event->note_messages =item $event->has_other_info =item $event->other_info =item $event->other_info_messages =back =head1 SOURCE The source code repository for Test2 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 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 03weak.t100644001750001750 231614772042323 23514 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Tools/Test-Refcount#!/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; done_testing_double.t100644001750001750 175214772042323 23761 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder; use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->create; # $tb methods expect to be wrapped in at least 1 sub sub done_testing { $tb->done_testing(@_) } sub ok { $tb->ok(@_) } { # Normalize test output local $ENV{HARNESS_ACTIVE}; ok(1); ok(1); ok(1); #line 24 done_testing(3); done_testing; done_testing; } my $Test = Test::Builder->new; $Test->plan( tests => 1 ); $Test->level(0); $Test->is_eq($tb->read, <<"END", "multiple done_testing"); ok 1 ok 2 ok 3 1..3 not ok 4 - done_testing() was already called at $0 line 24 # Failed test 'done_testing() was already called at $0 line 24' # at $0 line 25. not ok 5 - done_testing() was already called at $0 line 24 # Failed test 'done_testing() was already called at $0 line 24' # at $0 line 26. END run_subtest_inherit.t100644001750001750 433014772042323 24045 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept context/; # Test a subtest that should inherit the trace from the tool that calls it my ($file, $line) = (__FILE__, __LINE__ + 1); my $events = intercept { my_tool_inherit() }; is(@$events, 1, "got 1 event"); my $e = shift @$events; ok($e->isa('Test2::Event::Subtest'), "got a subtest event"); is($e->trace->file, $file, "subtest is at correct file"); is($e->trace->line, $line, "subtest is at correct line"); my $plan = pop @{$e->subevents}; ok($plan->isa('Test2::Event::Plan'), "Removed plan"); for my $se (@{$e->subevents}) { is($se->trace->file, $file, "subtest event is at correct file"); is($se->trace->line, $line, "subtest event is at correct line"); ok($se->facets->{assert}->pass, "subtest event passed"); } # Test a subtest that should NOT inherit the trace from the tool that calls it ($file, $line) = (__FILE__, __LINE__ + 1); $events = intercept { my_tool_no_inherit() }; is(@$events, 1, "got 1 event"); $e = shift @$events; ok($e->isa('Test2::Event::Subtest'), "got a subtest event"); is($e->trace->file, $file, "subtest is at correct file"); is($e->trace->line, $line, "subtest is at correct line"); $plan = pop @{$e->subevents}; ok($plan->isa('Test2::Event::Plan'), "Removed plan"); for my $se (@{$e->subevents}) { ok($se->trace->file ne $file, "subtest event is not in our file"); ok($se->trace->line ne $line, "subtest event is not on our line"); ok($se->facets->{assert}->{pass}, "subtest event passed"); } done_testing; # Make these tools appear to be in a different file/line #line 100 'fake.pm' sub my_tool_inherit { my $ctx = context(); run_subtest( 'foo', sub { ok(1, 'a'); ok(2, 'b'); is_deeply(\@_, [qw/arg1 arg2/], "got args"); }, {buffered => 1, inherit_trace => 1}, 'arg1', 'arg2' ); $ctx->release; } sub my_tool_no_inherit { my $ctx = context(); run_subtest( 'foo', sub { ok(1, 'a'); ok(2, 'b'); is_deeply(\@_, [qw/arg1 arg2/], "got args"); }, {buffered => 1, inherit_trace => 0}, 'arg1', 'arg2' ); $ctx->release; } preload_diag_note.t100644001750001750 123314772042323 23653 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy_And_Test2use strict; use warnings; if ("$]" < 5.008) { print "1..0 # SKIP Test cannot run on perls below 5.8.0\n"; exit 0; } BEGIN { require Test2::API; Test2::API::test2_start_preload(); } use Test::More; my ($stdout, $stderr) = ('', ''); { local *STDOUT; open(STDOUT, '>', \$stdout) or die "Could not open temp STDOUT"; local *STDERR; open(STDERR, '>', \$stderr) or die "Could not open temp STDOUT"; diag("test\n", "diag\nfoo"); note("test\n", "note\nbar"); } Test2::API::test2_stop_preload(); is($stdout, < 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 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 Interceptor000755001750001750 014772042323 21141 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/HubTerminator.pm100644001750001750 133514772042323 23765 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Hub/Interceptorpackage Test2::Hub::Interceptor::Terminator; use strict; use warnings; our $VERSION = '1.302210'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor::Terminator - Exception class used by Test2::Hub::Interceptor =head1 SOURCE The source code repository for Test2 can be found at 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 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 01count.t100644001750001750 517214772042323 23716 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Tools/Test-Refcount#!/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; fork_with_new_stdout.t100644001750001750 147414772042323 24215 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!perl -w use strict; use warnings; use Test2::Util qw/CAN_FORK/; BEGIN { unless (CAN_FORK) { require Test::More; Test::More->import(skip_all => "fork is not supported"); } } use IO::Pipe; use Test::Builder; use Config; my $b = Test::Builder->new; $b->reset; $b->plan('tests' => 2); my $pipe = IO::Pipe->new; if (my $pid = fork) { $pipe->reader; my ($one, $two) = <$pipe>; $b->like($one, qr/ok 1/, "ok 1 from child"); $b->like($two, qr/1\.\.1/, "1..1 from child"); waitpid($pid, 0); } else { require Test::Builder::Formatter; $b->{Stack}->top->format(Test::Builder::Formatter->new()); $pipe->writer; $b->reset; $b->no_plan; $b->output($pipe); $b->ok(1); $b->done_testing; } =pod #actual 1..2 ok 1 1..1 ok 1 ok 2 #expected 1..2 ok 1 ok 2 =cut 289-compare-array-bounds.t100644001750001750 142414772042323 23701 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::V0; my $foo = [qw(a b c d e f g )]; is($foo, 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'; # 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-z]/; #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. }); done_testing; 27-2-Test2-Tools-Compare.t100644001750001750 26414772042323 23360 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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(); sample_tests000755001750001750 014772042323 22242 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simpleexit.plx100644001750001750 4014772042323 24032 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Builder; exit 1; Introduction.pm100644001750001750 1622614772042323 24165 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Testingpackage Test2::Manual::Testing::Introduction; use strict; use warnings; our $VERSION = '1.302210'; 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 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 try_it_done_testing.t100644001750001750 60014772042323 24265 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/acceptanceuse strict; use warnings; use Test2::API qw/context/; sub done_testing { my $ctx = context(); die "Test Already ended!" if $ctx->hub->ended; $ctx->hub->finalize($ctx->trace, 1); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } ok(1, "First"); ok(1, "Second"); done_testing; 1; 746-forking-subtest.t100644001750001750 205014772042323 23770 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/regressionuse strict; use warnings; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/context intercept test2_stack/; use Test2::Util qw/CAN_FORK/; BEGIN { skip_all "System cannot fork" unless CAN_FORK; } my $events = intercept { Test2::API::run_subtest("this subtest forks" => sub { if (fork) { wait; isnt($?, 0, "subprocess died"); } else { # Prevent the exception from being rendered to STDERR, people have # complained about STDERR noise in tests before. close STDERR; die "# Expected warning from subtest"; }; }, {no_fork => 1}); }; my @subtests = grep {; $_->isa('Test2::Event::Subtest') } @$events; if (is(@subtests, 1, "only one subtest run, effectively")) { my @subokay = grep {; $_->facets->{assert} } @{ $subtests[0]->subevents }; is(@subokay, 1, "we got one test result inside the subtest"); ok(! $subokay[0]->causes_fail, "...and it passed"); } else { # give up, we're already clearly broken } done_testing; death.plx100644001750001750 37514772042323 24201 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); require Dev::Null; Test::Simple->import(tests => 5); tie *STDERR, 'Dev::Null'; ok(1); ok(1); ok(1); $! = 0; die "This is a test"; builder_loaded_late.t100644001750001750 107414772042323 24162 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy_And_Test2use strict; use warnings; # HARNESS-NO-PRELOAD use Test2::Tools::Tiny; use Test2::API qw/intercept test2_stack/; plan 3; my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; require Test::Builder; }; is(@warnings, 2, "got warnings"); like( $warnings[0], qr/Test::Builder was loaded after Test2 initialization, this is not recommended/, "Warn about late Test::Builder load" ); like( $warnings[1], qr/Formatter Test::Builder::Formatter loaded too late to be used as the global formatter/, "Got the formatter warning" ); thread_init_warning.t100644001750001750 60614772042323 24216 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy_And_Test2use strict; use warnings; use Test2::Util qw/CAN_THREAD/; BEGIN { unless(CAN_THREAD) { require Test::More; Test::More->import(skip_all => "threads are not supported"); } } use threads; my @warns; { local $SIG{__WARN__} = sub { push @warns => @_ }; require Test::More; } Test::More::is_deeply(\@warns, [], "No init warning"); Test::More::done_testing(); Squasher.pm100644001750001750 712714772042323 24172 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/API/InterceptResultpackage Test2::API::InterceptResult::Squasher; use strict; use warnings; our $VERSION = '1.302210'; use Carp qw/croak/; use List::Util qw/first/; use Test2::Util::HashBase qw{ {+EVENTS}; } sub can_squash { my $self = shift; my ($event) = @_; # No info, no squash return unless $event->has_info; # Do not merge up if one of these is true return if first { $event->$_ } 'causes_fail', 'has_assert', 'has_bailout', 'has_errors', 'has_plan', 'has_subtest'; # Signature if we can squash return $event->trace_signature; } sub process { my $self = shift; my ($event) = @_; return if $self->squash_up($event); return if $self->squash_down($event); $self->flush_down($event); push @{$self->{+EVENTS}} => $event; return; } sub squash_down { my $self = shift; my ($event) = @_; my $sig = $self->can_squash($event) or return; $self->flush_down() if $self->{+DOWN_SIG} && $self->{+DOWN_SIG} ne $sig; $self->{+DOWN_SIG} ||= $sig; push @{$self->{+DOWN_BUFFER}} => $event; return 1; } sub flush_down { my $self = shift; my ($into) = @_; my $sig = delete $self->{+DOWN_SIG}; my $buffer = delete $self->{+DOWN_BUFFER}; return unless $buffer && @$buffer; my $fsig = $into ? $into->trace_signature : undef; if ($fsig && $fsig eq $sig) { $self->squash($into, @$buffer); } else { push @{$self->{+EVENTS}} => @$buffer if $buffer; } } sub clear_up { my $self = shift; return unless $self->{+UP_CLEAR}; delete $self->{+UP_INTO}; delete $self->{+UP_SIG}; delete $self->{+UP_CLEAR}; } sub squash_up { my $self = shift; my ($event) = @_; no warnings 'uninitialized'; $self->clear_up; if ($event->has_assert) { if(my $sig = $event->trace_signature) { $self->{+UP_INTO} = $event; $self->{+UP_SIG} = $sig; $self->{+UP_CLEAR} = 0; } else { $self->{+UP_CLEAR} = 1; $self->clear_up; } return; } my $into = $self->{+UP_INTO} or return; # Next iteration should clear unless something below changes that $self->{+UP_CLEAR} = 1; # Only merge into matching trace signatres my $sig = $self->can_squash($event); return unless $sig eq $self->{+UP_SIG}; # OK Merge! Do not clear merge in case the return event is also a matching sig diag-only $self->{+UP_CLEAR} = 0; $self->squash($into, $event); return 1; } sub squash { my $self = shift; my ($into, @from) = @_; push @{$into->facet_data->{info}} => $_->info for @from; } sub DESTROY { my $self = shift; return unless $self->{+EVENTS}; $self->flush_down(); return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult::Squasher - Encapsulation of the algorithm that squashes diags into assertions. =head1 DESCRIPTION Internal use only, please ignore. =head1 SOURCE The source code repository for Test2 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 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 NonInteractiveTesting.t100644001750001750 54314772042323 24502 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Requireuse Test2::Bundle::Extended -target => 'Test2::Require::NonInteractiveTesting'; { local $ENV{NONINTERACTIVE_TESTING} = 0; is($CLASS->skip(), 'NonInteractive test, set the $NONINTERACTIVE_TESTING environment variable to run it', "will skip"); $ENV{NONINTERACTIVE_TESTING} = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; done_testing_with_plan.t100644001750001750 23114772042323 24443 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->plan( tests => 2 ); $tb->ok(1); $tb->ok(1); $tb->done_testing(2); ipc_files_abort_exit.t100644001750001750 365014772042323 24510 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/regressionuse strict; use warnings; use Test2::Tools::Tiny; use Test2::Util qw/CAN_REALLY_FORK/; BEGIN { skip_all "Set AUTHOR_TESTING to run this test" unless $ENV{AUTHOR_TESTING}; skip_all "System cannot fork" unless CAN_REALLY_FORK; skip_all "known to fail on $]" if "$]" <= 5.006002; } use IPC::Open3 qw/open3/; use File::Temp qw/tempdir/; my $tempdir = tempdir(CLEANUP => 1); open(my $stdout, '>', "$tempdir/stdout") or die "Could not open: $!"; open(my $stderr, '>', "$tempdir/stderr") or die "Could not open: $!"; my $pid = open3(undef, ">&" . fileno($stdout), ">&" . fileno($stderr), $^X, '-Ilib', '-e', <<'EOT'); use Test2::IPC::Driver::Files; use Test2::IPC; use Test2::Tools::Tiny; use Test2::API qw/test2_ipc/; plan 1; ok(1); my $tmpdir = test2_ipc()->tempdir; open(my $fh, '>', "$tmpdir/leftover") or die "Could not open file: $!"; print $fh "XXX\n"; close($fh) or die "Could not clone file"; print "TEMPDIR: $tmpdir\n"; exit 100; EOT waitpid($pid, 0); my $exit = $?; open($stdout, '<', "$tempdir/stdout") or die "Could not open: $!"; open($stderr, '<', "$tempdir/stderr") or die "Could not open: $!"; $stdout = join "" => <$stdout>; $stderr = join "" => <$stderr>; is(($exit >> 8), 255, "exited 255"); like($stderr, qr{^IPC Fatal Error: Leftover files in the directory \(.*/leftover\)!$}m, "Got expected error"); like($stdout, qr{^Bail out! IPC Fatal Error: Leftover files in the directory \(.*leftover\)!$}m, "Got a bail printed"); if(ok($stdout =~ m/^TEMPDIR: (.*)$/m, "Found temp dir")) { chomp(my $tmpdir = $1); if (-d $tmpdir) { note "Cleaning up temp dir\n"; opendir(my $dh, $tmpdir) or diag "Could not open temp dir: $!"; for my $file (readdir($dh)) { next if $file =~ m/^\./; unlink("$tmpdir/$file") or diag "Could not remove $tmpdir/$file: $!"; } closedir($dh); rmdir($tmpdir) or diag "Could not remove temp dir: $!"; } } done_testing; extras.plx100644001750001750 31614772042323 24415 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(1); ok(1); ok(1); ok(0); ok(1); ok(0); NonInteractiveTesting.pm100644001750001750 241414772042323 24526 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Requirepackage Test2::Require::NonInteractiveTesting; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '1.302210'; sub skip { my $class = shift; return undef if $ENV{'NONINTERACTIVE_TESTING'}; return 'NonInteractive test, set the $NONINTERACTIVE_TESTING environment variable to run it'; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Require::NonInteractiveTesting - Only run a test when the NONINTERACTIVE_TESTING environment variable is set. =head1 DESCRIPTION It is common practice to write tests that are only run when the NONINTERACTIVE_TESTING environment variable is set. This module automates the (admittedly trivial) work of creating such a test. =head1 SYNOPSIS use Test2::Require::NonInteractiveTesting; ... 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 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 04reftypes.t100644001750001750 244614772042323 24433 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/modules/Tools/Test-Refcount#!/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; 694_note_diag_return_values.t100644001750001750 62114772042323 24616 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test::More; use strict; use warnings; use Test2::API qw/intercept/; my @returns; intercept { push @returns => diag('foo'); push @returns => note('foo'); my $tb = Test::Builder->new; push @returns => $tb->diag('foo'); push @returns => $tb->note('foo'); }; is(@returns, 4, "4 return values"); is_deeply(\@returns, [0, 0, 0, 0], "All note/diag returns are 0"); done_testing; 721-nested-streamed-subtest.t100644001750001750 561414772042323 24416 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse strict; use warnings; use Test2::Tools::Tiny; # This module's exports interfere with the ones in t/tools.pl use Test::More (); use Test::Builder::Formatter(); use Test2::API qw/run_subtest test2_stack/; { test2_stack->top; my $temp_hub = test2_stack->new_hub(); $temp_hub->format(Test::Builder::Formatter->new()); my $output = capture { run_subtest( 'parent', sub { run_subtest( 'buffered', sub { ok(1, 'b1'); ok(1, 'b2'); }, {buffered => 1}, ); run_subtest( 'streamed', sub { ok(1, 's1'); ok(1, 's2'); }, {buffered => 0}, ); }, {buffered => 1}, ); }; test2_stack->pop($temp_hub); Test::More::subtest( 'Test2::API::run_subtest', sub { is($output->{STDERR}, q{}, 'no output on stderr'); like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); } ); } { test2_stack->top; my $temp_hub = test2_stack->new_hub(); $temp_hub->format(Test::Builder::Formatter->new()); my $output = capture { run_subtest( 'parent', sub { run_subtest( 'buffered', sub { ok(1, 'b1'); ok(1, 'b2'); }, {buffered => 1}, ); Test::More::subtest( 'streamed', sub { ok(1, 's1'); ok(1, 's2'); }, {buffered => 0}, ); }, {buffered => 1}, ); }; test2_stack->pop($temp_hub); Test::More::subtest( 'Test::More::subtest and Test2::API::run_subtest', sub { is($output->{STDERR}, q{}, 'no output on stderr'); like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); } ); } done_testing; too_few.plx100644001750001750 25314772042323 24551 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(1); require.plx100644001750001750 2614772042323 24541 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; success.plx100644001750001750 33714772042323 24562 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(5, 'yep'); ok(3, 'beer'); ok("wibble", "wibble"); ok(1); Plugin000755001750001750 014772042323 22213 5ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/ToolingTestExit.pm100644001750001750 437514772042323 24473 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Tooling/Pluginpackage Test2::Manual::Tooling::Plugin::TestExit; our $VERSION = '1.302210'; 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 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 done_testing_with_number.t100644001750001750 35414772042323 25007 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->level(0); $tb->ok(1, "testing done_testing() with no arguments"); $tb->ok(1, " another test so we're not testing just one"); $tb->done_testing(2); async_subtest_missing_parent.t100644001750001750 73214772042323 25300 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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; InterceptResult000755001750001750 014772042323 23037 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/APIEvent.t100644001750001750 7644314772042323 24503 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/API/InterceptResultuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API::InterceptResult::Event; my $CLASS = 'Test2::API::InterceptResult::Event'; tests facet_map => sub { ok(!$CLASS->can('plugins'), "Did not expose 'plugins' sub"); my $fm = $CLASS->facet_map; is_deeply($fm->{__GENERIC__}, {class => 'Test2::API::InterceptResult::Facet', loaded => 1}, "Generic '__GENERIC__'"); is_deeply($CLASS->facet_info('about'), {class => 'Test2::EventFacet::About', list => 0, loaded => 1}, "Found 'about' facet"); is_deeply($CLASS->facet_info('amnesty'), {class => 'Test2::EventFacet::Amnesty', list => 1, loaded => 1}, "Found 'amnesty' facet"); is_deeply($CLASS->facet_info('assert'), {class => 'Test2::EventFacet::Assert', list => 0, loaded => 1}, "Found 'assert' facet"); is_deeply($CLASS->facet_info('control'), {class => 'Test2::EventFacet::Control', list => 0, loaded => 1}, "Found 'control' facet"); is_deeply($CLASS->facet_info('errors'), {class => 'Test2::EventFacet::Error', list => 1, loaded => 1}, "Found 'errors' facet"); is_deeply($CLASS->facet_info('hubs'), {class => 'Test2::EventFacet::Hub', list => 1, loaded => 1}, "Found 'hubs' facet"); is_deeply($CLASS->facet_info('info'), {class => 'Test2::EventFacet::Info', list => 1, loaded => 1}, "Found 'info' facet"); is_deeply($CLASS->facet_info('meta'), {class => 'Test2::EventFacet::Meta', list => 0, loaded => 1}, "Found 'meta' facet"); is_deeply($CLASS->facet_info('parent'), {class => 'Test2::EventFacet::Parent', list => 0, loaded => 1}, "Found 'parent' facet"); is_deeply($CLASS->facet_info('plan'), {class => 'Test2::EventFacet::Plan', list => 0, loaded => 1}, "Found 'plan' facet"); is_deeply($CLASS->facet_info('render'), {class => 'Test2::EventFacet::Render', list => 1, loaded => 1}, "Found 'render' facet"); is_deeply($CLASS->facet_info('trace'), {class => 'Test2::EventFacet::Trace', list => 0, loaded => 1}, "Found 'trace' facet"); }; tests init => sub { # This is just here to make sure the later test is meaningful. If this # starts to fail it probably means this test needs to be changed. ok(!$INC{'Test2/API/InterceptResult.pm'}, "Did not load result class yes"); my $one = $CLASS->new(); ok($one->isa($CLASS), "Got an instance"); is_deeply($one->facet_data, {}, "Got empty data"); is($one->result_class, 'Test2::API::InterceptResult', "Got default result class"); ok($INC{'Test2/API/InterceptResult.pm'}, "Loaded result class"); like( exception { $CLASS->new(facet_data => {assert => [{}]}) }, qr/^Facet 'assert' is an only-one facet, but got 'ARRAY' instead of a hashref/, "Check list vs non-list when we can (check for single)" ); like( exception { $CLASS->new(facet_data => {info => {}}) }, qr/^Facet 'info' is a list facet, but got 'HASH' instead of an arrayref/, "Check list vs non-list when we can (check for list)" ); like( exception { $CLASS->new(facet_data => {info => [{},[]]}) }, qr/Got item type 'ARRAY' in list-facet 'info', all items must be hashrefs/, "Check each item in a list facet is a hashref" ); my $two = $CLASS->new(facet_data => {assert => {}, info => [{}]}); ok($two->isa($CLASS), "Got an instance with some actual facets"); }; tests facet => sub { my $one = $CLASS->new(facet_data => { other_single => {}, other_list => [{}], assert => {pass => 1, details => 'xxx'}, info => [ {tag => 'DIAG', details => 'xxx'}, {tag => 'NOTE', details => 'xxx'}, ], }); ok(($one->facet('assert'))[0]->isa('Test2::EventFacet::Assert'), "Bless the assert facet"); ok(($one->facet('other_list'))[0]->isa('Test2::EventFacet'), "Bless the other_list as generic"); ok(($one->facet('other_single'))[0]->isa('Test2::EventFacet'), "Bless the other_single as generic"); ok(($one->facet('other_list'))[0]->isa('Test2::API::InterceptResult::Facet'), "Bless the other_list as generic"); ok(($one->facet('other_single'))[0]->isa('Test2::API::InterceptResult::Facet'), "Bless the other_single as generic"); is(($one->facet('other_list'))[0]->foo, undef, "Generic gives us autoload for field access"); is_deeply( [$one->facet('xxx')], [], "Got an empty list when facet is not present", ); is_deeply( [$one->facet('assert')], [{pass => 1, details => 'xxx'}], "One item list for non-list facets", ); is_deeply( [$one->facet('info')], [ {tag => 'DIAG', details => 'xxx'}, {tag => 'NOTE', details => 'xxx'}, ], "Full list for list facets" ); }; tests the_facet => sub { my $one = $CLASS->new(facet_data => { other_single => {}, other_list => [{}], assert => {pass => 1, details => 'xxx'}, info => [ {tag => 'DIAG', details => 'xxx'}, {tag => 'NOTE', details => 'xxx'}, ], }); ok($one->the_facet('assert')->isa('Test2::EventFacet::Assert'), "Bless the assert facet"); ok($one->the_facet('other_list')->isa('Test2::EventFacet'), "Bless the other_list as generic"); ok($one->the_facet('other_single')->isa('Test2::EventFacet'), "Bless the other_single as generic"); ok($one->the_facet('other_list')->isa('Test2::API::InterceptResult::Facet'), "Bless the other_list as generic"); ok($one->the_facet('other_single')->isa('Test2::API::InterceptResult::Facet'), "Bless the other_single as generic"); is($one->the_facet('other_list')->foo, undef, "Generic gives us autoload for field access"); is_deeply( $one->the_facet('xxx'), undef, "Got an undef when facet is not present", ); is_deeply( $one->the_facet('assert'), {pass => 1, details => 'xxx'}, "One item", ); like( exception { $one->the_facet('info') }, qr/'the_facet' called for facet 'info', but 'info' has '2' items/, "the_facet dies if there are more than one" ); }; tests causes_failure => sub { my $one = $CLASS->new(facet_data => { assert => {pass => 1, details => 'xxx'}}); ok(!$one->causes_fail, "No failure for passing test"); ok(!$one->causes_failure, "No failure for passing test (alt name)"); my $two = $CLASS->new(facet_data => { assert => {pass => 0, details => 'xxx'}}); ok($two->causes_fail, "Failure for failing test"); ok($two->causes_failure, "Failure for failing test (alt name)"); my $three = $CLASS->new( facet_data => { assert => {pass => 0, details => 'xxx'}, amnesty => [{tag => 'TODO', details => 'a todo'}], } ); ok(!$three->causes_fail, "No failure for failing test (with amnesty)"); ok(!$three->causes_failure, "No failure for failing test (with amnesty) (alt name)"); }; tests trace => sub { my $one = $CLASS->new; is($one->trace, undef, "No trace to get"); is($one->frame, undef, "No frame to get"); is($one->trace_details, undef, "No trace to get trace_details from"); is($one->trace_file, undef, "No trace to get trace_file from"); is($one->trace_line, undef, "No trace to get trace_line from"); is($one->trace_package, undef, "No trace to get trace_package from"); is($one->trace_subname, undef, "No trace to get trace_subname from"); is($one->trace_tool, undef, "No trace to get trace_tool from"); my $stamp = 123; my $two = $CLASS->new( facet_data => { trace => { frame => [], details => 'xxx', pid => 1, tid => 1, stamp => $stamp, }, } ); is_deeply($two->the_trace, {details => 'xxx', frame => [], pid => 1, tid => 1, stamp => $stamp}, "Got trace"); is_deeply([$two->trace], [{details => 'xxx', frame => [], pid => 1, tid => 1, stamp => $stamp}], "Got trace"); is($two->trace_details, 'xxx', "get trace_details"); is($two->trace_stamp, $stamp, "get trace_stamp"); is_deeply($two->frame, [], "No frame to get"); is($two->trace_file, undef, "No frame to get trace_file from"); is($two->trace_line, undef, "No frame to get trace_line from"); is($two->trace_package, undef, "No frame to get trace_package from"); is($two->trace_subname, undef, "No frame to get trace_subname from"); is($two->trace_tool, undef, "No frame to get trace_tool from"); my $three = $CLASS->new( facet_data => { trace => { details => 'xxx', frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'ok'], pid => 1, tid => 1, stamp => $stamp, }, } ); is_deeply($three->the_trace, {details => 'xxx', frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'ok'], pid => 1, tid => 1, stamp => $stamp}, "Got trace"); is($three->trace_details, 'xxx', "get trace_details"); is($three->trace_stamp, $stamp, "get trace_stamp"); is_deeply($three->frame, ['Foo::Bar', 'Foo/Bar.pm', 42, 'ok'], "Got frame"); is($three->trace_file, 'Foo/Bar.pm', "Got trace_file"); is($three->trace_line, 42, "Got trace_line"); is($three->trace_package, 'Foo::Bar', "Got trace_package"); is($three->trace_subname, 'ok', "Got trace_subname"); is($three->trace_tool, 'ok', "Got trace_tool"); }; tests brief => sub { my $one = $CLASS->new( facet_data => { control => {halt => 1, details => "some reason to bail out"}, errors => [{tag => 'ERROR', details => "some kind of error"}], assert => {pass => 1, details => "some passing assert"}, plan => {count => 42}, } ); is($one->brief, $one->bailout_brief, "bail-out is used when present"); delete $one->{facet_data}->{control}; is($one->brief, $one->error_brief, "error is next"); delete $one->{facet_data}->{errors}; is($one->brief, $one->assert_brief, "assert is next"); delete $one->{facet_data}->{assert}; is($one->brief, $one->plan_brief, "plan is last"); delete $one->{facet_data}->{plan}; is_deeply( [$one->brief], [], "Empty list if no briefs are available." ); }; tests summary => sub { my $one = $CLASS->new(); is_deeply( $one->summary, { brief => '', causes_failure => 0, trace_line => undef, trace_file => undef, trace_tool => undef, trace_details => undef, facets => [], }, "Got summary for empty event" ); my $two = $CLASS->new(facet_data => { assert => {pass => 0}, trace => {frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'ok'], details => 'a trace'}, parent => {}, plan => {count => 1}, control => {halt => 1, details => "bailout wins"}, info => [ {tag => 'DIAG', details => 'diag 1'}, {tag => 'DIAG', details => 'diag 2'}, {tag => 'NOTE', details => 'note 1'}, {tag => 'NOTE', details => 'note 2'}, {tag => 'OTHER', details => 'other 1'}, {tag => 'OTHER', details => 'other 2'}, ], }); is_deeply( $two->summary, { brief => 'BAILED OUT: bailout wins', causes_failure => 1, trace_line => 42, trace_file => 'Foo/Bar.pm', trace_tool => 'ok', trace_details => 'a trace', facets => [qw{ assert control info parent plan trace }], }, "Got summary for lots" ); is_deeply( $two->summary(fields => [qw/trace_line trace_file/]), { trace_line => 42, trace_file => 'Foo/Bar.pm', }, "Got summary, specific fields" ); is_deeply( $two->summary(remove => [qw/brief facets/]), { causes_failure => 1, trace_line => 42, trace_file => 'Foo/Bar.pm', trace_tool => 'ok', trace_details => 'a trace', }, "Got summary, removed some fields" ); }; tests assert => sub { my $one = $CLASS->new(); ok(!$one->has_assert, "Not an assert"); is_deeply([$one->assert], [], "empty list for assert()"); is_deeply([$one->assert_brief], [], "empty list for assert_brief()"); my $two = $CLASS->new(facet_data => {assert => {pass => 1, details => 'foo'}}); ok($two->has_assert, "Is an assert"); is_deeply([$two->assert], [{pass => 1, details => 'foo'}], "got assert item"); is($two->assert_brief, "PASS", "got PASS for assert_brief()"); my $three = $CLASS->new(facet_data => { assert => {pass => 0, details => 'foo'}, amnesty => [ {tag => 'TODO', details => 'todo 1'}, {tag => 'SKIP', details => 'skip 1'}, {tag => 'OOPS', details => 'oops 1'}, {tag => 'TODO', details => 'todo 2'}, {tag => 'SKIP', details => 'skip 2'}, {tag => 'OOPS', details => 'oops 2'}, ], }); ok($three->has_assert, "Is an assert"); is_deeply([$three->assert], [{pass => 0, details => 'foo'}], "got assert item"); is($three->assert_brief, "FAIL with amnesty", "Fail with amnesty"); my $four = $CLASS->new(facet_data => { assert => {pass => 0, details => 'foo'}, amnesty => [ {tag => 'TODO'}, {tag => 'SKIP'}, {tag => 'OOPS'}, ], }); ok($four->has_assert, "Is an assert"); is_deeply([$four->assert], [{pass => 0, details => 'foo'}], "got assert item"); is($four->assert_brief, "FAIL with amnesty", "Fail with amnesty"); }; tests subtest => sub { my $one = $CLASS->new(); ok(!$one->has_subtest, "Not a subtest"); is_deeply([$one->subtest], [], "subtest() returns empty list"); is_deeply([$one->subtest_result], [], "subtest_result returns an empty list"); my $two = $CLASS->new( facet_data => { parent => { hid => '1234', children => [], state => { bailed_out => undef, count => 5, failed => 1, follows_plan => 1, is_passing => 0, nested => 1, skip_reason => undef, }, }, } ); ok($two->has_subtest, "has a subtest"); is_deeply([$two->subtest], [$two->facet_data->{parent}], "subtest() returns 1 item list"); my $res = $two->subtest_result; ok($res->isa('Test2::API::InterceptResult'), "Got a result instance"); }; tests flatten => sub { my $one = $CLASS->new(); is_deeply( $one->flatten, { causes_failure => 0, trace_file => undef, trace_line => undef }, "Empty event flattens to almost nothing" ); my $two = $CLASS->new( facet_data => { hubs => [{details => "DO NOT SHOW"}], meta => {details => "DO NOT SHOW"}, control => {details => "A control"}, assert => {pass => 1, details => "Test Name"}, trace => { frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'Test2::Tools::Tiny::ok'], details => "Trace Details", }, parent => { details => "A Subtest", children => [ $CLASS->new(facet_data => {assert => {pass => 1, details => 'nested assertion'}}), $CLASS->new(facet_data => {plan => {count => 1}}), ], }, errors => [ {tag => 'error', fail => 0, details => "not a fatal error"}, {tag => 'error', fail => 1, details => "a fatal error"}, ], info => [ {tag => 'DIAG', details => 'diag 1'}, {tag => 'DIAG', details => 'diag 2'}, {tag => 'NOTE', details => 'note 1'}, {tag => 'NOTE', details => 'note 2'}, {tag => 'INFO', details => 'info 1'}, {tag => 'INFO', details => 'info 2'}, ], amnesty => [ {tag => 'TODO', details => 'todo 1'}, {tag => 'TODO', details => 'todo 2'}, {tag => 'SKIP', details => 'skip 1'}, {tag => 'SKIP', details => 'skip 2'}, {tag => 'OKOK', details => 'okok 1'}, {tag => 'OKOK', details => 'okok 2'}, ], other_single => {details => 'other single'}, other_multi => [{details => 'other multi'}], }, ); is_deeply( $two->flatten(include_subevents => 1), { # Summaries causes_failure => 0, trace_details => 'Trace Details', trace_file => 'Foo/Bar.pm', trace_line => 42, # Info diag => ['diag 1', 'diag 2'], info => ['info 1', 'info 2'], note => ['note 1', 'note 2'], # Amnesty okok => ['okok 1', 'okok 2'], skip => ['skip 1', 'skip 2'], todo => ['todo 1', 'todo 2'], # Errors error => ['not a fatal error', 'FATAL: a fatal error'], # Assert name => 'Test Name', pass => 1, # Control control => 'A control', # Other other_multi => ['other multi'], other_single => 'other single', # Subtest related subtest => { follows_plan => 1, is_passing => 1, count => 1, failed => 0, plan => 1, }, subevents => [ { name => 'nested assertion', trace_line => undef, causes_failure => 0, pass => 1, trace_file => undef, }, { trace_file => undef, plan => '1', trace_line => undef, causes_failure => 0, } ], }, "Very full flattening, with subevents" ); is_deeply( $two->flatten(), { # Summaries causes_failure => 0, trace_details => 'Trace Details', trace_file => 'Foo/Bar.pm', trace_line => 42, # Info diag => ['diag 1', 'diag 2'], info => ['info 1', 'info 2'], note => ['note 1', 'note 2'], # Amnesty okok => ['okok 1', 'okok 2'], skip => ['skip 1', 'skip 2'], todo => ['todo 1', 'todo 2'], # Errors error => ['not a fatal error', 'FATAL: a fatal error'], # Assert name => 'Test Name', pass => 1, # Control control => 'A control', # Other other_multi => ['other multi'], other_single => 'other single', # Subtest related subtest => { follows_plan => 1, is_passing => 1, count => 1, failed => 0, plan => 1, }, }, "Very full flattening, no subevents" ); my $three = $CLASS->new( facet_data => { trace => { frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'Test2::Tools::Tiny::ok'], }, control => {halt => 1, details => "need to bail dude!"}, amnesty => [{tag => 'TODO', details => 'todo 1'}], }, ); is_deeply( $three->flatten(include_subevents => 1), { # Summaries causes_failure => 0, trace_file => 'Foo/Bar.pm', trace_line => 42, bailed_out => "need to bail dude!", # Amnesty does not show without an assert or parent }, "Bail-out test" ); my $four = $CLASS->new( facet_data => { trace => {frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'Test2::Tools::Tiny::ok']}, errors => [{tag => 'ERROR', details => 'an error', fail => 1}], amnesty => [{tag => 'TODO', details => 'todo 1'}], }, ); is_deeply( $four->flatten(), { # Summaries causes_failure => 0, trace_file => 'Foo/Bar.pm', trace_line => 42, todo => ['todo 1'], error => ['FATAL: an error'], }, "Include amnesty when there is a fatal error" ); is_deeply( $four->flatten(fields => [qw/trace_file trace_line/]), { trace_file => 'Foo/Bar.pm', trace_line => 42, }, "Filtered to only specific fields" ); is_deeply( $four->flatten(remove => [qw/todo error/]), { # Summaries causes_failure => 0, trace_file => 'Foo/Bar.pm', trace_line => 42, }, "Remove specific fields" ); }; tests bailout => sub { my $one = $CLASS->new(); ok(!$one->has_bailout, "No bailout"); is_deeply([$one->bailout], [], "no bailout"); is_deeply([$one->bailout_brief], [], "no bailout"); is_deeply([$one->bailout_reason], [], "no bailout"); my $two = $CLASS->new( facet_data => { trace => { frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'Test2::Tools::Tiny::ok'], }, control => {halt => 1, details => "need to bail dude!"}, }, ); ok($two->has_bailout, "did bail out"); is_deeply([$two->bailout], [{halt => 1, details => "need to bail dude!"}], "Got the bailout"); is_deeply([$two->bailout_brief], ["BAILED OUT: need to bail dude!"], "Got the bailout brief"); is_deeply([$two->bailout_reason], ["need to bail dude!"], "Got the bailout reason"); }; tests plan => sub { my $one = $CLASS->new; ok(!$one->has_plan, "No plan"); is_deeply([$one->plan], [], "No plan"); is_deeply([$one->plan_brief], [], "No plan"); my $two = $CLASS->new(facet_data => {plan => { count => 42 }}); ok($two->has_plan, "Got a plan"); is_deeply([$two->plan], [{ count => 42 }], "Got the plan facet"); is_deeply([$two->plan_brief], ["PLAN 42"], "Got the brief"); $two->{facet_data}->{plan}->{details} = "foo bar baz"; is_deeply([$two->plan_brief], ["PLAN 42: foo bar baz"], "Got the brief with details"); $two->{facet_data}->{plan}->{count} = 0; is_deeply([$two->plan_brief], ["SKIP ALL: foo bar baz"], "Got the skip form no count with details"); $two->{facet_data}->{plan}->{count} = 1; $two->{facet_data}->{plan}->{skip} = 1; is_deeply([$two->plan_brief], ["SKIP ALL: foo bar baz"], "Got the skip with details"); $two->{facet_data}->{plan}->{skip} = 0; $two->{facet_data}->{plan}->{none} = 1; is_deeply([$two->plan_brief], ["NO PLAN: foo bar baz"], "Got the 'NO PLAN' with details"); }; tests amnesty => sub { my $one = $CLASS->new(); ok(!$one->has_amnesty, "No amnesty"); ok(!$one->has_todos, "No todos"); ok(!$one->has_skips, "No skips"); ok(!$one->has_other_amnesty, "No other amnesty"); is_deeply([$one->amnesty], [], "amnesty list is empty"); is_deeply([$one->todos], [], "todos list is empty"); is_deeply([$one->skips], [], "skips list is empty"); is_deeply([$one->other_amnesty], [], "other_amnesty list is empty"); is_deeply([$one->amnesty_reasons], [], "amnesty_reasons list is empty"); is_deeply([$one->todo_reasons], [], "todo_reasons list is empty"); is_deeply([$one->skip_reasons], [], "skip_reasons list is empty"); is_deeply([$one->other_amnesty_reasons], [], "other_amnesty_reasons list is empty"); my $two = $CLASS->new( facet_data => { amnesty => [ {tag => 'TODO', details => 'todo 1'}, {tag => 'TODO', details => 'todo 2'}, {tag => 'SKIP', details => 'skip 1'}, {tag => 'SKIP', details => 'skip 2'}, {tag => 'OKOK', details => 'okok 1'}, {tag => 'OKOK', details => 'okok 2'}, ], }, ); ok($two->has_amnesty, "amnesty"); ok($two->has_todos, "todos"); ok($two->has_skips, "skips"); ok($two->has_other_amnesty, "other amnesty"); is_deeply( [$two->amnesty], [ {tag => 'TODO', details => 'todo 1'}, {tag => 'TODO', details => 'todo 2'}, {tag => 'SKIP', details => 'skip 1'}, {tag => 'SKIP', details => 'skip 2'}, {tag => 'OKOK', details => 'okok 1'}, {tag => 'OKOK', details => 'okok 2'}, ], "amnesty list", ); is_deeply( [$two->todos], [ {tag => 'TODO', details => 'todo 1'}, {tag => 'TODO', details => 'todo 2'}, ], "todos list", ); is_deeply( [$two->skips], [ {tag => 'SKIP', details => 'skip 1'}, {tag => 'SKIP', details => 'skip 2'}, ], "skips list", ); is_deeply( [$two->other_amnesty], [ {tag => 'OKOK', details => 'okok 1'}, {tag => 'OKOK', details => 'okok 2'}, ], "other_amnesty list", ); is_deeply( [$two->amnesty_reasons], [ 'todo 1', 'todo 2', 'skip 1', 'skip 2', 'okok 1', 'okok 2', ], "amnesty_reasons list is empty" ); is_deeply( [$two->todo_reasons], [ 'todo 1', 'todo 2', ], "todo_reasons list is empty" ); is_deeply( [$two->skip_reasons], [ 'skip 1', 'skip 2', ], "skip_reasons list is empty" ); is_deeply( [$two->other_amnesty_reasons], [ 'okok 1', 'okok 2', ], "other_amnesty_reasons list is empty" ); }; tests errors => sub { my $one = $CLASS->new(); ok(!$one->has_errors, "No errors"); is_deeply([$one->errors], [], "No errors"); is_deeply([$one->error_messages], [], "No errors"); is_deeply([$one->error_brief], [], "No errors"); my $two = $CLASS->new(facet_data => { errors => [{tag => 'error', details => 'a non fatal error'}], }); ok($two->has_errors, "Got errors"); is_deeply([$two->errors], [{tag => 'error', details => 'a non fatal error'}], "Got the error"); is_deeply([$two->error_messages], ['a non fatal error'], "Got the message"); is_deeply([$two->error_brief], ['ERROR: a non fatal error'], "Got the brief"); my $three = $CLASS->new(facet_data => { errors => [{tag => 'error', details => "a non fatal\nerror"}], }); ok($three->has_errors, "Got errors"); is_deeply([$three->errors], [{tag => 'error', details => "a non fatal\nerror"}], "Got the error"); is_deeply([$three->error_messages], ["a non fatal\nerror"], "Got the message"); is_deeply([$three->error_brief], ["ERROR: a non fatal [...]"], "Got the brief"); my $four = $CLASS->new(facet_data => { errors => [ {tag => 'error', details => "a fatal error", fail => 1}, {tag => 'error', details => "a non fatal error", fail => 0}, ], }); ok($four->has_errors, "Got errors"); is_deeply( [$four->errors], [ {tag => 'error', details => "a fatal error", fail => 1}, {tag => 'error', details => "a non fatal error", fail => 0}, ], "Got the error" ); is_deeply( [$four->error_messages], [ "a fatal error", "a non fatal error", ], "Got the message" ); is_deeply([$four->error_brief], ['ERRORS: a fatal error [...]'], "Got the brief"); }; tests info => sub { my $one = $CLASS->new(); ok(!$one->has_info, "No info"); ok(!$one->has_diags, "No diags"); ok(!$one->has_notes, "No notes"); ok(!$one->has_other_info, "No other info"); is_deeply([$one->info], [], "info list is empty"); is_deeply([$one->diags], [], "diags list is empty"); is_deeply([$one->notes], [], "notes list is empty"); is_deeply([$one->other_info], [], "other_info list is empty"); is_deeply([$one->info_messages], [], "info_messages list is empty"); is_deeply([$one->diag_messages], [], "diag_messages list is empty"); is_deeply([$one->note_messages], [], "note_messages list is empty"); is_deeply([$one->other_info_messages], [], "other_info_messages list is empty"); my $two = $CLASS->new( facet_data => { info => [ {tag => 'DIAG', details => 'diag 1'}, {tag => 'DIAG', details => 'diag 2'}, {tag => 'NOTE', details => 'note 1'}, {tag => 'NOTE', details => 'note 2'}, {tag => 'INFO', details => 'info 1'}, {tag => 'INFO', details => 'info 2'}, ], }, ); ok($two->has_info, "info"); ok($two->has_diags, "diags"); ok($two->has_notes, "notes"); ok($two->has_other_info, "other info"); is_deeply( [$two->info], [ {tag => 'DIAG', details => 'diag 1'}, {tag => 'DIAG', details => 'diag 2'}, {tag => 'NOTE', details => 'note 1'}, {tag => 'NOTE', details => 'note 2'}, {tag => 'INFO', details => 'info 1'}, {tag => 'INFO', details => 'info 2'}, ], "info list", ); is_deeply( [$two->diags], [ {tag => 'DIAG', details => 'diag 1'}, {tag => 'DIAG', details => 'diag 2'}, ], "diags list", ); is_deeply( [$two->notes], [ {tag => 'NOTE', details => 'note 1'}, {tag => 'NOTE', details => 'note 2'}, ], "notes list", ); is_deeply( [$two->other_info], [ {tag => 'INFO', details => 'info 1'}, {tag => 'INFO', details => 'info 2'}, ], "other_info list", ); is_deeply( [$two->info_messages], [ 'diag 1', 'diag 2', 'note 1', 'note 2', 'info 1', 'info 2', ], "info_messages list is empty" ); is_deeply( [$two->diag_messages], [ 'diag 1', 'diag 2', ], "diag_messages list is empty" ); is_deeply( [$two->note_messages], [ 'note 1', 'note 2', ], "note_messages list is empty" ); is_deeply( [$two->other_info_messages], [ 'info 1', 'info 2', ], "other_info_messages list is empty" ); }; done_testing; nested_context_exception.t100644001750001750 413314772042323 25053 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 } use Test2::Tools::Tiny; use Test2::API qw/context/; skip_all("known to fail on $]") if "$]" <= 5.006002; sub outer { my $code = shift; my $ctx = context(); $ctx->note("outer"); my $out = eval { $code->() }; $ctx->release; return $out; } sub dies { my $ctx = context(); $ctx->note("dies"); die "Foo"; } sub bad_store { my $ctx = context(); $ctx->note("bad store"); return $ctx; # Emulate storing it somewhere } sub bad_simple { my $ctx = context(); $ctx->note("bad simple"); return; } my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; eval { dies() }; } ok(!@warnings, "no warnings") || diag @warnings; @warnings = (); my $keep = bad_store(); eval { my $x = 1 }; # Ensure an eval changing $@ does not meddle. { local $SIG{__WARN__} = sub { push @warnings => @_ }; ok(1, "random event"); } ok(@warnings, "got warnings"); like( $warnings[0], qr/context\(\) was called to retrieve an existing context/, "got expected warning" ); $keep = undef; { @warnings = (); local $SIG{__WARN__} = sub { push @warnings => @_ }; bad_simple(); } ok(@warnings, "got warnings"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); @warnings = (); outer(\&dies); { local $SIG{__WARN__} = sub { push @warnings => @_ }; ok(1, "random event"); } ok(!@warnings, "no warnings") || diag @warnings; @warnings = (); { local $SIG{__WARN__} = sub { push @warnings => @_ }; outer(\&bad_store); } ok(@warnings, "got warnings"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); { @warnings = (); local $SIG{__WARN__} = sub { push @warnings => @_ }; outer(\&bad_simple); } ok(@warnings, "got warnings") || diag @warnings; like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); done_testing; Subtest_buffer_formatter.t100644001750001750 517014772042323 25016 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/behavioruse strict; use warnings; use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept test2_stack/; { package Formatter::Hide; sub write { } sub hide_buffered { 1 } sub terminate { } sub finalize { } package Formatter::Show; sub write { } sub hide_buffered { 0 } sub terminate { } sub finalize { } package Formatter::NA; sub write { } sub terminate { } sub finalize { } } my %HAS_FORMATTER; my $events = intercept { my $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_none} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_none} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); ##################### test2_stack->top->format(bless {}, 'Formatter::Hide'); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_hide} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_hide} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); ##################### test2_stack->top->format(bless {}, 'Formatter::Show'); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_show} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_show} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); ##################### $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{unbuffered_na} = $hub->format ? 1 : 0; }; run_subtest('unbuffered', $code); test2_stack->top->format(bless {}, 'Formatter::NA'); $code = sub { my $hub = test2_stack->top; $HAS_FORMATTER{buffered_na} = $hub->format ? 1 : 0; }; run_subtest('buffered', $code, 'BUFFERED'); }; ok(!$HAS_FORMATTER{unbuffered_none}, "Unbuffered with no parent formatter has no formatter"); ok( $HAS_FORMATTER{unbuffered_show}, "Unbuffered where parent has 'show' formatter has formatter"); ok( $HAS_FORMATTER{unbuffered_hide}, "Unbuffered where parent has 'hide' formatter has formatter"); ok(!$HAS_FORMATTER{buffered_none}, "Buffered with no parent formatter has no formatter"); ok( $HAS_FORMATTER{buffered_show}, "Buffered where parent has 'show' formatter has formatter"); ok(!$HAS_FORMATTER{buffered_hide}, "Buffered where parent has 'hide' formatter has no formatter"); done_testing; two_fail.plx100644001750001750 30014772042323 24704 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(0); ok(1); ok(1); ok(0); ok(1); one_fail.plx100644001750001750 30014772042323 24654 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(2); ok(0); ok(1); ok(2); current_test_without_plan.t100644001750001750 35114772042323 25235 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # Test that current_test() will work without a declared plan. use Test::Builder; my $tb = Test::Builder->new; $tb->current_test(2); print <<'END'; ok 1 ok 2 END $tb->ok(1, "Third test"); $tb->done_testing(3); done_testing_with_no_plan.t100644001750001750 23014772042323 25136 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w use strict; use Test::Builder; my $tb = Test::Builder->new; $tb->plan( "no_plan" ); $tb->ok(1); $tb->ok(1); $tb->done_testing(2); Interceptor000755001750001750 014772042323 22306 5ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/HubTerminator.t100644001750001750 24714772042323 24742 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/Hub/Interceptoruse strict; use warnings; use Test2::Tools::Tiny; use Test2::Hub::Interceptor::Terminator; ok($INC{'Test2/Hub/Interceptor/Terminator.pm'}, "loaded"); done_testing; five_fail.plx100644001750001750 27514772042323 25037 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; use lib 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(0); ok(0); ok(''); ok(0); ok(0); ToolStarts.pm100644001750001750 576214772042323 25041 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Tooling/Pluginpackage Test2::Manual::Tooling::Plugin::ToolStarts; our $VERSION = '1.302210'; 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 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 done_testing_plan_mismatch.t100644001750001750 157214772042323 25326 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Builder#!/usr/bin/perl -w # What if there's a plan and done_testing but they don't match? use strict; BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { unshift @INC, 't/lib'; } } use Test::Builder; use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->create; # TB methods expect to be wrapped sub ok { $tb->ok(@_) } sub plan { $tb->plan(@_) } sub done_testing { $tb->done_testing(@_) } { # Normalize test output local $ENV{HARNESS_ACTIVE}; plan( tests => 3 ); ok(1); ok(1); ok(1); #line 24 done_testing(2); } my $Test = Test::Builder->new; $Test->plan( tests => 1 ); $Test->level(0); $Test->is_eq($tb->read, <<"END"); 1..3 ok 1 ok 2 ok 3 not ok 4 - planned to run 3 but done_testing() expects 2 # Failed test 'planned to run 3 but done_testing() expects 2' # at $0 line 24. END 291-async-subtest-done-testing.t100644001750001750 63614772042323 25026 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse Test2::V0; use Test2::Require::RealFork; use Test2::Tools::AsyncSubtest qw/fork_subtest/; my $st = fork_subtest foo => sub { ok(1, "Just a pass"); like( warning { done_testing }, qr/A plan should not be set inside an async-subtest \(did you call done_testing\(\)\?\)/, "We get a warning if we call done_testing inside an asyncsubtest" ); }; $st->finish; done_testing; TestingDone.pm100644001750001750 536614772042323 25146 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Tooling/Pluginpackage Test2::Manual::Tooling::Plugin::TestingDone; our $VERSION = '1.302210'; 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 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 27-3-Test2-Tools-ClassicCompare.t100644001750001750 31114772042323 24654 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/regressionuse 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(); Squasher.t100644001750001750 743514772042323 25170 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Test2/modules/API/InterceptResultuse strict; use warnings; use Test2::Tools::Tiny; use Test2::API::InterceptResult::Squasher; use Test2::API::InterceptResult::Event; my $CLASS = 'Test2::API::InterceptResult::Squasher'; my $trace1 = {pid => $$, tid => 0, cid => 1, frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'ok']}; my $trace2 = {pid => $$, tid => 0, cid => 2, frame => ['Foo::Bar', 'Foo/Bar.pm', 43, 'note']}; my $trace3 = {pid => $$, tid => 0, cid => 3, frame => ['Foo::Bar', 'Foo/Bar.pm', 44, 'subtest']}; my $trace4 = {pid => $$, tid => 0, cid => 4, frame => ['Foo::Bar', 'Foo/Bar.pm', 45, 'diag']}; my @raw = ( # These 4 should merge Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace1, info => [{tag => 'DIAG', details => 'about to fail'}], }), Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace1, assert => { pass => 0, details => 'fail' }, }), Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace1, info => [{tag => 'DIAG', details => 'it failed'}], }), Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace1, info => [{tag => 'DIAG', details => 'it failed part 2'}], }), # Same trace, but should not merge as it has an assert Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace1, assert => { pass => 0, details => 'fail again' }, info => [{tag => 'DIAG', details => 'it failed again'}], }), # Stand alone note Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace2, info => [{tag => 'NOTE', details => 'Take Note!'}], }), # Subtest, note, assert, diag as 3 events, should be merged Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace3, info => [{tag => 'NOTE', details => 'About to start subtest'}], }), Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace3, assert => { pass => 0, details => 'failed subtest' }, parent => { details => 'foo', state => {}, children => [] }, }), Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace3, info => [{tag => 'DIAG', details => 'Subtest failed'}], }), # Stand alone diag Test2::API::InterceptResult::Event->new(facet_data => { trace => $trace4, info => [{tag => 'DIAG', details => 'Diagnosis: Murder'}], }), ); my @events; my $squasher = $CLASS->new(events => \@events); ok($squasher->isa($CLASS), "Got an instance"); $squasher->process($_) for @raw; $squasher = undef; is_deeply( [map { $_->facet_data } @events], [ { trace => $trace1, assert => {pass => 0, details => 'fail'}, info => [ {tag => 'DIAG', details => 'about to fail'}, {tag => 'DIAG', details => 'it failed'}, {tag => 'DIAG', details => 'it failed part 2'}, ], }, { trace => $trace1, assert => {pass => 0, details => 'fail again'}, info => [{tag => 'DIAG', details => 'it failed again'}], }, { trace => $trace2, info => [{tag => 'NOTE', details => 'Take Note!'}], }, { trace => $trace3, assert => {pass => 0, details => 'failed subtest'}, parent => {details => 'foo', state => {}, children => []}, info => [ {tag => 'NOTE', details => 'About to start subtest'}, {tag => 'DIAG', details => 'Subtest failed'}, ], }, { trace => $trace4, info => [{tag => 'DIAG', details => 'Diagnosis: Murder'}], }, ], "Squashed events as expected" ); done_testing; 870-experimental-warnings.t100644001750001750 70214772042323 25310 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/Legacy/Regressionuse strict; use warnings; use Test2::Tools::Tiny; BEGIN { skip_all "Not testing before 5.18 or after 5.37.10" if $] < 5.018 or $] >= 5.037010; } require Test::More; *cmp_ok = \&Test::More::cmp_ok; no warnings "experimental::smartmatch"; no if !exists $warnings::Offsets{"experimental::smartmatch"}, warnings => 'deprecated'; my $warnings = warnings { cmp_ok(1, "~~", 1) }; ok(!@$warnings, "Did not get any warnings"); done_testing; too_few_fail.plx100644001750001750 26214772042323 25544 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(0); ok(1); ok(0); ToolCompletes.pm100644001750001750 351114772042323 25502 0ustar00exodistexodist000000000000Test-Simple-1.302210/lib/Test2/Manual/Tooling/Pluginpackage Test2::Manual::Tooling::Plugin::ToolCompletes; our $VERSION = '1.302210'; 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 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 death_in_eval.plx100644001750001750 43014772042323 25666 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; use Carp; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); ok(1); ok(1); ok(1); eval { die "Foo"; }; ok(1); eval "die 'Bar'"; ok(1); eval { croak "Moo"; }; pre_plan_death.plx100644001750001750 44114772042323 26053 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_tests# ID 20020716.013, the exit code would become 0 if the test died # before a plan. require Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); close STDERR; die "Knife?"; Test::Simple->import(tests => 3); ok(1); ok(1); ok(1); last_minute_death.plx100644001750001750 41414772042323 26577 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); require Dev::Null; tie *STDERR, 'Dev::Null'; ok(1); ok(1); ok(1); ok(1); ok(1); $! = 0; die "This is a test"; death_with_handler.plx100644001750001750 53014772042323 26722 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 2); # Test we still get the right exit code despite having a die # handler. $SIG{__DIE__} = sub {}; require Dev::Null; tie *STDERR, 'Dev::Null'; ok(1); ok(1); $! = 0; die "This is a test"; missing_done_testing.plx100644001750001750 23014772042323 27315 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(); ok(1); one_fail_without_plan.plx100644001750001750 23014772042323 27453 0ustar00exodistexodist000000000000Test-Simple-1.302210/t/lib/Test/Simple/sample_testsrequire Test::Simple; push @INC, 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(); ok(0);